#!/bin/env tclsh

package require sqlite3
package require Thread
package require tcl::chan::string

set init {
  package require sha256

  proc readbak {path} {
    set fd [open $path rb]
    set magic [read $fd 6]
    if {$magic != "AMEBAK"} {
      close $fd
      return -code error "invalid magic string: \"$magic\""
    }

    set ver [read $fd 1]
    binary scan $ver c ver
    if {$ver != 0} {
      close $fd
      return -code error "archive file too new: $ver (self: 0)"
    }

    set mode [read $fd 1]
    read $fd 8; # skip filesize
    switch -- $mode {
      r {}
      F {
        zlib push inflate $fd -level 9
      }
      default {
        close $fd
        return -code error "unknown compression mode: $mode"
      }
    }

    set ret [read $fd]
    close $fd
    return $ret
  }
  proc readstore {store hash {hex 0}} {
    set hexhash $hash
    if {!$hex} { set hexhash [binary encode hex $hash] }
    set path $store
    append path "/[string range $hexhash 0 1]"
    append path "/[string range $hexhash 2 3]"
    append path "/[string range $hexhash 4 5]/"
    append path "/[string range $hexhash 6 end]"
    if {[file exists $path]} {
      return [readbak $path]
    } else {
      return -code error "missing file"
    }
  }

  proc writebak {path data} {
    binary scan $data c _
    set bench [string range $data 0 10000000]
    binary scan $bench c _
    set Fbench [zlib deflate $bench 9]

    set fd [open $path wb]
    puts -nonewline $fd "AMEBAK\0"

    set compress 0
    if {[string length $Fbench] < ([string length $bench] * 95 / 100)} {
      puts -nonewline $fd "F"
      set compress 1
    } else { puts -nonewline $fd "r" }

    puts -nonewline $fd [binary format W [string length $data]]

    if {$compress} { zlib push deflate $fd -level 9 }

    puts -nonewline $fd $data
    close $fd
  }
  proc writestore {store data {hex 0}} {
    set hash [::sha2::sha256 -bin -- $data]
    set hexhash [binary encode hex $hash]
    set path $store
    append path "/[string range $hexhash 0 1]"
    append path "/[string range $hexhash 2 3]"
    append path "/[string range $hexhash 4 5]/"
    file mkdir $path
    set path "$path/[string range $hexhash 6 end]"

    if {![file exists $path]} {
      writebak $path $data
    }

    if {$hex} {
      return $hexhash
    } else {
      return $hash
    }
  }

  proc statbak {path} {
    set fd [open $path rb]
    set magic [read $fd 6]
    if {$magic != "AMEBAK"} {
      close $fd
      return -code error "invalid magic string: \"$magic\""
    }

    set ver [read $fd 1]
    binary scan $ver c ver
    if {$ver != 0} {
      close $fd
      return -code error "archive file too new: $ver (self: 0)"
    }

    set mode [read $fd 1]
    switch -- $mode {
      r { set mode raw }
      F { set mode deflate }
      default {
        close $fd
        return -code error "unknown compression mode: $mode"
      }
    }

    set disksize [file size $path]
    binary scan [read $fd 8] W datasize

    close $fd
    return [list ver $ver mode $mode disksize $disksize datasize $datasize]
  }
  proc statstore {store hash {hex 0}} {
    set hexhash $hash
    if {!$hex} { set hexhash [binary encode hex $hash] }
    set path $store
    append path "/[string range $hexhash 0 1]"
    append path "/[string range $hexhash 2 3]"
    append path "/[string range $hexhash 4 5]/"
    append path "/[string range $hexhash 6 end]"
    if {![file exists $path]} return

    dict replace [statbak $path] path $path
  }
}
eval $init

namespace eval ::tar {}
proc ::tar::nextrec {fd} {
  set hdr [read $fd 512]
  binary scan $hdr c _
  if {[string length $hdr] != 512} { die "got partial header: [string length $hdr] b" }

  binary scan $hdr a100c24a11c1c12c8a1c* name blind1 size _ blind2 _ type blind3
  set name [lindex [split $name "\0"] 0]

  if {$name == {}} return

  set data [read $fd [expr {$size}]]
  if {$size % 512 != 0} {
    read $fd [expr {512 - ($size % 512)}]
  }

  return [list name $name type $type data [binary encode hex $data]  blind1 $blind1 blind2 $blind2 blind3 $blind3]
}
proc ::tar::fmtrec {rec} {
  set name [dict get $rec name]
  set type [dict get $rec type]
  set size [expr {[string length [dict get $rec data]] / 2}]
  set size [format %011o $size]

  set blind1 [dict get $rec blind1]
  set blind2 [dict get $rec blind2]
  set blind3 [dict get $rec blind3]

  set hdr [binary format a100c24a12c12A8a1c* $name $blind1 $size $blind2 "" $type $blind3]
  binary scan $hdr c* bytes
  set checksum 0
  foreach byte $bytes {
    incr checksum [expr {$byte & 0xFF}]
  }
  set checksum [format %07o $checksum]
  set hdr [binary format a100c24a12c12a8a1c* $name $blind1 $size $blind2 $checksum $type $blind3]

  append hdr [binary decode hex [dict get $rec data]]
  if {$size % 512 != 0} {
    append hdr [binary format a[expr {512 - ($size % 512)}] ""]
  }

  return $hdr
}


proc usage {} {
  global argv0
  puts stderr {usage: $argv0 command store ?args ...?
commands:
  init
    - initialize a store in store
  importlist name ?listfile?
    - imports the contents of listfile under name, treating each line as a filepath
    - if listfile is ommitted, reads stdin
  importtar name ?tarfile?
    - imports the contents of tarfile under name. will not auto-decompress.
    - if tarfile is ommitted, reads stdin
  import ?filepath?
    - stores the contents of filepath, returning the hash
    - if filepath is ommitted, reads stdin
  export id
    - exports the contents of backup id to a file named like NAME_DATE
  print hash
    - prints the contents of the file named by hash on stdout
  stat hash
    - prints metadata about the file named by hash}
  exit -1
}
proc die {reason} {
  global argv0
  puts stderr "$argv0: fatal: $reason"
  exit -2
}


if {[llength $argv] < 2} usage

set argv [lassign $argv command store]
set dbpath "$store/index.db"
set arpath "$store/archive"

if {$command == "init"} {
  if {[file exists $dbpath]} { die "won't overwrite \"$dbpath\"." }
  file mkdir $store
  file mkdir $arpath
  sqlite3 db $dbpath

  db eval {
    CREATE TABLE tarballs (name TEXT NOT NULL, type TEXT NOT NULL, ref TEXT NOT NULL, desc TEXT NOT NULL, date TEXT NOT NULL);
  }
  exit
}

if {[catch {sqlite3 db $dbpath -create false}]} { die "can't find a store at \"$store\"." }

set fd [open /proc/cpuinfo r]
set nproc [llength [regexp -all -lineanchor -inline "^processor" [read $fd]]]
close $fd
set pool [tpool::create -maxworkers $nproc -initcmd [concat $init "; " [list set arpath $arpath]]]

switch -- $command {
  importlist {
    if {[llength $argv] ni {1 2}} usage
    set fname [lindex $argv 0]

    if {[llength $argv] == 2} {
      set fd [open [lindex $argv 1]]
    } else {
      set fd stdin
    }

    set files [split [string trim [read $fd]] "\n"]
    set joblist {}
    set filelist {}
    if {$fd != "stdin"} { close $fd }

    foreach filename $files {
      if {![file exists $filename]} {
        puts stderr "warning: \"$filename\" doesn't exist"
        continue
      }

      set script [concat [list set filename $filename] "; " {
        set fd [open $filename rb]
        set data [read $fd]
        close $fd

        set hash [writestore $arpath $data 1]
        return [list [string trimleft [file normalize $filename] "/"] $hash]
      }]

      lappend joblist [tpool::post $pool $script]
    }

    foreach job $joblist {
      tpool::wait $pool $job
      append filelist " [tpool::get $pool $job]"
    }

    set filelist [lsort -stride 2 $filelist]

    set ref [writestore $arpath $filelist 1]
    set date [clock seconds]
    set rowid [db eval {
      INSERT INTO tarballs VALUES ($fname, "list", $ref, "", $date) RETURNING rowid;
    }]

    puts stderr "inserted as archive $rowid with hash $ref"
  }

  importtar {
    if {[llength $argv] ni {1 2}} usage
    set fname [lindex $argv 0]

    if {[llength $argv] == 2} {
      set fd [open [lindex $argv 1]] rb
    } else {
      set fd stdin
      fconfigure stdin -translation binary
    }

    set joblist {}
    set result {}

    while {[set record [::tar::nextrec $fd]] != {}} {
      set script [concat [list set record $record] "; " {
        set hash [writestore $arpath [binary decode hex [dict get $record data]] 1]
        dict set record data $hash
        return $record
      }]

      lappend joblist [tpool::post $pool $script]
    }

    if {$fd != "stdin"} { close $fd }

    foreach job $joblist {
      tpool::wait $pool $job
      append result [::tar::fmtrec [tpool::get $pool $job]]
    }

    append result [binary format a[expr {16384 - ([string length $result] % 16384)}] ""]

    set ref [writestore $arpath $result 1]
    set date [clock seconds]
    set rowid [db eval {
      INSERT INTO tarballs VALUES ($fname, "tar", $ref, "", $date) RETURNING rowid;
    }]

    puts stderr "inserted as archive $rowid with hash $ref"
  }

  export {
    if {[llength $argv] != 1} usage

    set rowid [lindex $argv 0]
    set record [db eval {
      SELECT ref,type,name,date FROM tarballs WHERE rowid = $rowid;
    }]
    if {[llength $record] == 0} { die "unknown archive id" }
    lassign $record ref type name date

    set exportname [regsub "/" "${name}_[clock format $date -format {%Y-%m-%d_%H.%M.%S}]" "-"]
    set archive [readstore $arpath $ref 1]

    switch -- $type {
      list {
        file mkdir $exportname

        set joblist {}
        foreach {path hash} $archive {
          set script [concat [list set path "$exportname/$path"] "; " [list set hash $hash] "; " {
            puts "$hash -> $path"
            file mkdir [file dirname $path]
            set fd [open "$path" wb]
            puts -nonewline $fd [readstore $arpath $hash 1]
            close $fd
          }]

          lappend joblist [tpool::post $pool $script]
        }

        foreach job $joblist {
          tpool::wait $pool $job
        }
      }
      tar {
        set exportname "$exportname.tar"
        set exportfd [open $exportname wb]

        set importfd [::tcl::chan::string $archive]
        fconfigure $importfd -translation binary

        set joblist {}
        while {[set record [::tar::nextrec $importfd]] != {}} {
          set script [concat [list set record $record] "; " {
            dict set record data [binary encode hex [readstore $arpath [dict get $record data] 1]]
            return $record
          }]

          lappend joblist [tpool::post -nowait $pool $script]
        }

        foreach job $joblist {
          tpool::wait $pool $job
          puts -nonewline $exportfd [::tar::fmtrec [tpool::get $pool $job]]
        }
        puts -nonewline $exportfd [binary format a[expr {16384 - ([tell $exportfd] % 16384)}] ""]

        close $exportfd
      }
      default {
        die "database corrupt: unknown archive type \"$type\""
      }
    }

    puts "exported to $exportname"
  }

  print {
    if {[llength $argv] != 1} usage

    set stat [statstore $arpath [lindex $argv 0] 1]
    if {$stat == {}} { die "unknown hash" }

    puts [readstore $arpath [lindex $argv 0] 1]
  }
  stat {
    if {[llength $argv] != 1} usage

    set stat [statstore $arpath [lindex $argv 0] 1]
    if {$stat == {}} { die "unknown hash" }

    puts "file [lindex $argv 0]:"
    puts "  version: [dict get $stat ver]"
    puts "  compression: [dict get $stat mode]"
    if {[dict get $stat mode] != "raw"} {
      puts "  compressed size (bytes): [dict get $stat disksize]"
    }
    puts "  data size (bytes): [dict get $stat datasize]"
  }

  import {
    if {[llength $argv] > 1} usage
    if {[llength $argv] == 1} {
      set fd [open [lindex $argv 0]]
    } else {
      set fd stdin
    }

    set data [read $fd]

    set hash [writestore $arpath $data 1]
    puts "imported as $hash"
  }

  default usage
}