Browse files

sample project for prototyping and -cafile option for curl-retry

  • Loading branch information...
pulpofred committed Apr 4, 2016
1 parent f5b6f8c commit cff426b6f9ab12e9f711b0a156b937136f4fde77
Showing with 59 additions and 7 deletions.
  1. +4 −1 build.tcl
  2. +12 −6 fruho/main.tcl
  3. +43 −0 sample/main.tcl
@@ -247,8 +247,11 @@ proc push-update {os arch tohost} {
set ::FRUHO_VERSION 0.0.19
prepare-lib sklib 0.0.0
build linux x86_64 sample base-tk-[base-ver x86_64] {sklib-0.0.0 tls- Tclx-8.4 cmdline-1.5 json-1.3.3 uri-1.2.5 base64-2.4.2 tktray-1.3.9}
build-total x86_64
#build-total x86_64
#package require i18n
#i18n code2msg ./fruho/main.tcl {es pl} ./fruho/messages.txt
@@ -915,6 +915,7 @@ proc is-config-received {profileid} {
proc curl-dispatch {chout cherr hostport args} {
if {[string match bootstrap:* $hostport]} {
# in cadir rename crts to have hash names: openssl x509 -hash -in your.crt -noout
curl-retry $chout $cherr -hostports $::model::Hostports -hindex ::model::hostport_lastok -expected_hostname -cadir [model CADIR] {*}$args
} else {
curl-retry $chout $cherr -hostports [lrepeat 3 $hostport] {*}$args
@@ -1738,6 +1739,10 @@ proc frame-toolbar {p} {
set tb [ttk::frame $p.tb -borderwidth 0 -relief raised]
hypertext $tb.improve "Help improve this program. Provide your <><feedback.> We listen."
button $tb.options -relief flat -command OptionsClicked
#TODO convert to consistent ttk or plain theme
#ttk::style configure TStyleFlat -relief flat
#ttk::button $tb.options -style TStyleFlat -command OptionsClicked
#ttk::button $tb.options -command OptionsClicked
img place 24/options $tb.options
label $tb.bang
img place 16/bang $tb.bang
@@ -2686,7 +2691,7 @@ proc this-pcv {} {
# This proc is a mess - no clear semantics for retrying on failure (is non-200 http status code a success to be pushed to tryout, or fail to tryerr, or retry?)
proc curl-retry {tryout tryerr args} {
try {
fromargs {-urlpath -indiv_timeout -hostports -hindex -proto -expected_hostname -method -gettofile -postfromfile -basicauth -cadir} \
fromargs {-urlpath -indiv_timeout -hostports -hindex -proto -expected_hostname -method -gettofile -postfromfile -basicauth -cadir -cafile} \
{/ 5000 {} _ https}
upvar $hindex host_index
if {![info exists host_index]} {
@@ -2735,13 +2740,14 @@ proc curl-retry {tryout tryerr args} {
dict set opts -querychannel [open $postfromfile r]
dict set opts -type text/plain
# reregister tls handling with proper CAdir store
if {$cadir eq ""} {
#TODO make it cross-platform
https init -cadir /etc/ssl/certs
} else {
# reregister tls handling with proper CAdir/CAfile store
# this is quite nasty because https/tls CA store selection is stateful
if {$cadir ne ""} {
https init -cadir $cadir
if {$cafile ne ""} {
https init -cafile $cafile
# use hostip for url but expect host for TLS domain verification if not overwritten by expected_hostname option
# -expected-hostname given in options takes precedence over individual resolved host names
# so overwrite here only if the option was not provided
@@ -0,0 +1,43 @@
# sample/main.tcl
# This should be the preamble to every application
# It makes it possible to run as starpack or as a sourced script
if {![catch {package require starkit}]} {
#this is to initialize starkit variables
package require http
package require tls
package require https
package require linuxdeps
package require skutil
# unix requires Tclx which litters global namespace. Need to clean up to avoid conflict with csp
rename ::select ""
package require csp
namespace import csp::*
proc run {} {
# https init -cadir /etc/ssl/certs
https curl -command [-> chhttp]
set tok [<- $chhttp]
upvar #0 $tok state
set ncode [http::ncode $tok]
if {[string is integer -strict $ncode]} {
set ncode_nonempty $ncode
set status [http::status $tok]
if {$status eq "ok" && $ncode == 200} {
set data [http::data $tok]
puts "data: $data"
puts "exit"
go run
vwait ::until

0 comments on commit cff426b

Please sign in to comment.