pkgfs prototype 2 (Tcl 8.7)

#! /usr/bin/env tclsh
# Copyright (c) 2021 D. Bohdan and contributors.
# License: MIT.
# ==============================================================================
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to deal
# in the Software without restriction, including without limitation the rights
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
# THE SOFTWARE.
# ==============================================================================

package require Tcl 8.7


namespace eval ::pkgfs {
    variable available {
        {core tcllib 1.20+}
        {
            ref
            QmRjsBWcu4W78F19vkXeBgwY5m8fpD2A6SHeSCCsAnHh5B

            checksum
            92479b4e7beb8e2682dac733fd5399252f00fe2219d5532d9065aeb634360c49

            algo
            sha256
        }

        {dbohdan autoopts 0.6.1}
        {
            ref
            Qmea9ksHVd8sGTDuREX3jvgeymggnkE3eaWUkXEnS6Y5cH

            checksum
            0102ef871955d26ba17c42d0ec4fcb0e32f67c4b5f1a7b12880456dba199c095

            algo
            sha256
        }

        {dbohdan jimlib 0.15.0}
        {
            ref
            QmSoxa3WhHdDUHQo7JjD4DVn5sUM9sxfDUrSQbhdBNuipQ

            checksum
            b413d8938818c4b100b968096a45a0686465bdd53392480a5bdb89ff11fb8329

            algo
            sha256
        }

        {de tdom 0.9.1 x86_64-linux-gnu}
        {
            ref
            QmcC3T579hjjVb88VnM6DzTgSTbNNoqtSdvKzasRfTvCzP

            checksum
            fbea1a7654b667047fbee42ae5a96d3bc4c4213f0a692dea9120cf102d5887d4

            algo
            sha256
        }

        {drh wapp 1.0.0}
        {
            ref
            QmUSNZqcQZUunP9gRn2kibz4TqAw1WAzXpdPizBFfQDFEq

            checksum
            86bbb01571ff21db275593d5366febd67fd47635b2c1db6085ef2db257b05c3f

            algo
            sha256
        }

        {mpcjanssen fcgi.tcl 0.5}
        {
            ref
            QmeiVCPoBvk9KMU85vKkoAZWekFWggjAp2iAYPkQQpkqi7

            checksum
            8dd51684a42b489e53b5636280f435fa8161b1a6c51dec766fe87273a85d4a1d

            algo
            sha256
        }
    }
    variable debug [dict getdef [array get ::env] PKGFS_DEBUG false]
    variable version 0.2.0
}

namespace eval ::pkgfs::checksum {
    variable command
    set command(sha256) {}
}

namespace eval ::pkgfs::http {
    variable client {}
    variable timeout 60
}

namespace eval ::pkgfs::ipfs {
    variable cacheDir [file normalize ~/.cache/pkgfs/]
    variable currentGateway 0
    variable gateways {
        https://cloudflare-ipfs.com/ipfs/%s
        https://ipfs.io/ipfs/%s
    }
}


proc ::pkgfs::configure {} {
    detect {
        package require http
        package require tls

        http::register https 443 [list ::tls::socket -autoservername true]

        set ::pkgfs::http::client tcl-http
    } {
        exec curl --version
        set ::pkgfs::http::client curl-cli
    } {
        try {
            exec busybox wget
        } on error e {
            if {![string match *--continue* $e]} {
                error {can't execure busybox wget}
            }
        }

        set ::pkgfs::http::client busybox-wget
    } {
        error {no usable HTTPS client}
    }

    detect {
        exec sha256sum << {}
        set ::pkgfs::checksum::command(sha256sum) sha256sum
    } {
        exec busybox sha256sum << {}
        set ::pkgfs::checksum::command(sha256sum) {busybox sha256sum}
    } {
        error {no usable sha256sum}
    }
}


proc ::pkgfs::detect args {
    set errorScript [lindex $args end]
    set args [lrange $args 0 end-1]
    set ok false

    foreach script $args {
        try {
            uplevel 1 $script
        } on ok _ {
            set ok true
            break
        } on error _ {}
    }

    if {!$ok} {
        uplevel 1 $errorScript
    }
}

proc ::pkgfs::grab-all {carts {tries 3}} {
    foreach cart $carts {
        grab $cart $tries
    }
}


proc ::pkgfs::grab {cart {tries 3}} {
    set pluggedIn false
    lassign [name-to-ref $cart] metadata fullName
    debug Grabbing cart $cart
    debug Full name is $fullName
    debug Ref is [dict get $metadata ref]

    for {set i 1} {$i <= $tries} {incr i} {
        debug Attempt number $i

        try {
            set f [ipfs::cache [dict get $metadata ref]]
            debug Cart is in $f
            plug-in $f
        } trap {PKGFS HTTP DOWNLOAD} e {
            debug HTTP client error: $e
        } trap {TCL ZIPFS} e {
            debug zipfs error: $e
            file delete $f
        } on ok _ {
            set pluggedIn true
            break
        }
    }

    if {!$pluggedIn} {
        return \
            -code error \
            -errorcode {PKGFS GRAB} \
            [list failed to download and plug in cart $cart] \
    }

    debug inb4
    set algo [dict get $metadata algo]
    set actual [checksum::$algo $f]
    debug done
    set expected [dict get $metadata checksum]
    if {$actual ne $expected} {
        return \
            -code error \
            -errorcode {PKGFS GRAB} \
            [list wrong $algo checksum $actual for cart $cart]
    }

    debug Plugged in $f
}


proc ::pkgfs::debug args {
    variable debug

    if {!$debug} return
    set caller [dict get [info frame -1] proc]
    puts stderr [format {PKGFS %-25s %s} $caller $args]
}


proc ::pkgfs::name-to-ref cart {
    variable available

    set len [llength $cart]

    foreach k [dict keys $available] {
        if {[lrange $k 0 $len-1] eq $cart} {
            return [list [dict get $available $k] $k]
        }
    }

    error [list unknown cart: $cart]
}


proc ::pkgfs::plug-in zip {
    set new [index-dirs [mount $zip]]
    lappend ::auto_path {*}$new

    return $new
}


proc ::pkgfs::mount zip {
    set root [zipfs root]
    set dest $root[file rootname [file tail $zip]]

    zipfs mount $dest $zip

    return $dest
}


proc ::pkgfs::index-dirs path {
    lmap f [zipfs list -glob $path*] {
        if {[file tail $f] ne {pkgIndex.tcl}} continue
        file dirname $f
    }
}


proc ::pkgfs::checksum::sha256 path {
    variable command

    lindex [exec {*}$command(sha256sum) $path] 0
}


proc ::pkgfs::ipfs::cache src {
    variable cacheDir

    file mkdir $cacheDir
    set dest [file join $cacheDir $src]

    if {[file exists $dest]} {
        ::pkgfs::debug Destination exists
        return $dest
    }

    ::pkgfs::debug Downloading
    download $src $dest

    return $dest
}


proc ::pkgfs::ipfs::download {src dest} {
    variable currentGateway
    variable gateways

    set gateway [lindex $gateways $currentGateway]
    set currentGateway [expr { ($currentGateway + 1) % [llength $gateways] }]
    ::pkgfs::debug Chose gateway $gateway
    ::pkgfs::http::download [format $gateway $src] $dest
}


proc ::pkgfs::http::download {url dest} {
    variable client

    try {
        ::pkgfs::debug Download client: $client
        $client $url $dest
    } on error {e opts} {
        dict set opts -errorcode {PKGFS HTTP DOWNLOAD}
        return -code error {*}$opts $e
    }
}


proc ::pkgfs::http::busybox-wget {url dest} {
    variable timeout

    # BusyBox wget never checks certificates.
    exec busybox wget \
        --no-check-certificate \
        -O $dest \
        -q \
        $url \
}


proc ::pkgfs::http::curl-cli {url dest} {
    variable timeout

    exec curl \
        --fail \
        --location \
        --max-time $timeout \
        --output $dest \
        --silent \
        $url \
}


proc ::pkgfs::http::tcl-http {src dest} {
    variable timeout

    try {
        set token [http::get $url -timeout ${timeout}000
        set data [http::data $token]

        set ch [open $dest wb]
        puts -nonewline $ch $data
    } finally {
        catch { http::cleanup $token }
        catch { close $ch }
    }
}


::pkgfs::configure

package provide pkgfs 0