BFG/bfg.tcl

#!/usr/bin/env tclsh
# BFG (aka Back/Forward/Go): a no-nonsense Tcl/Tk 8.6+ client for "small web" 
# currently supported protocols:
# Gopher (incl. gophers://), Finger, Nex, Spartan, Gemini 
# depends on Tk, Tcllib and TclTLS
# created by Luxferre in 2024, released into public domain

package require uri
package require tls
package require inifile
package require Tk

# overall vars
set tclpath [ file normalize [ info nameofexecutable ] ]
set scriptpath [ file normalize [ info script ] ]
set appdir [ file dirname $scriptpath ]
# check if we're running from a starpack
if [string match *app-bfg $appdir] {
  set appdir [ file normalize [ file join $appdir ".." ".." ".." ] ]
}
set config_file  [ file join $appdir "bfg.ini" ]

# configuration defaults
set bfg_net_timeout 4000
set bfg_theme "clam"
set bfg_widgetfont "TkDefaultFont"
set bfg_widgetfontsize 16
set bfg_entryfont "TkTextFont"
set bfg_entryfontsize 10
set bfg_statusfont "TkDefaultFont"
set bfg_statusfontsize 10
set bfg_textfont "TkFixedFont"
set bfg_textfontsize 12
set bfg_monofont "TkFixedFont"
set bfg_monofontsize 12
set bfg_main_fgcolor black
set bfg_main_bgcolor white
set bfg_link_fgcolor $bfg_main_fgcolor
set bfg_link_bgcolor $bfg_main_bgcolor
set bfg_focusedlink_fgcolor blue
set bfg_focusedlink_bgcolor $bfg_main_bgcolor
set bfg_highlight_fgcolor $bfg_main_fgcolor
set bfg_highlight_bgcolor yellow
set bfg_error_fgcolor red
set bfg_error_bgcolor $bfg_main_bgcolor

# read configuration from ini
set confini ""
catch {set confini [::ini::open $config_file -encoding utf-8]}
set val ""
set bookmarks ""
if {$confini ne ""} {
  set val [::ini::value $confini net timeout $bfg_net_timeout]
  if {$val ne ""} {set bfg_net_timeout $val}
  set val [::ini::value $confini widget ttkTheme $bfg_theme]
  if {$val ne ""} {set bfg_theme $val}
  set val [::ini::value $confini widget font $bfg_widgetfont]
  if {$val ne ""} {set bfg_widgetfont $val}
  set val [::ini::value $confini widget fontsize $bfg_widgetfontsize]
  if {$val ne ""} {set bfg_widgetfontsize $val}
  set val [::ini::value $confini widget entryfont $bfg_entryfont]
  if {$val ne ""} {set bfg_entryfont $val}
  set val [::ini::value $confini widget entryfontsize $bfg_entryfontsize]
  if {$val ne ""} {set bfg_entryfontsize $val}
  set val [::ini::value $confini widget statusfont $bfg_statusfont]
  if {$val ne ""} {set bfg_statusfont $val}
  set val [::ini::value $confini widget statusfontsize $bfg_statusfontsize]
  if {$val ne ""} {set bfg_statusfontsize $val}
  set val [::ini::value $confini style.general textfont $bfg_textfont]
  if {$val ne ""} {set bfg_textfont $val}
  set val [::ini::value $confini style.general textfontsize $bfg_textfontsize]
  if {$val ne ""} {set bfg_textfontsize $val}
  set val [::ini::value $confini style.general monofont $bfg_monofont]
  if {$val ne ""} {set bfg_monofont $val}
  set val [::ini::value $confini style.general monofontsize $bfg_monofontsize]
  if {$val ne ""} {set bfg_monofontsize $val}
  set val [::ini::value $confini style.general foreground $bfg_main_fgcolor]
  if {$val ne ""} {set bfg_main_fgcolor $val}
  set val [::ini::value $confini style.general background $bfg_main_bgcolor]
  if {$val ne ""} {set bfg_main_bgcolor $val}
  set val [::ini::value $confini style.link.normal foreground $bfg_link_fgcolor]
  if {$val ne ""} {set bfg_link_fgcolor $val}
  set val [::ini::value $confini style.link.normal background $bfg_link_bgcolor]
  if {$val ne ""} {set bfg_link_bgcolor $val}
  set val [::ini::value $confini style.link.focused foreground $bfg_focusedlink_fgcolor]
  if {$val ne ""} {set bfg_focusedlink_fgcolor $val}
  set val [::ini::value $confini style.link.focused background $bfg_focusedlink_bgcolor]
  if {$val ne ""} {set bfg_focusedlink_bgcolor $val}
  set val [::ini::value $confini style.highlight foreground $bfg_highlight_fgcolor]
  if {$val ne ""} {set bfg_highlight_fgcolor $val}
  set val [::ini::value $confini style.highlight background $bfg_highlight_bgcolor]
  if {$val ne ""} {set bfg_highlight_bgcolor $val}
  set val [::ini::value $confini style.error foreground $bfg_error_fgcolor]
  if {$val ne ""} {set bfg_error_fgcolor $val}
  set val [::ini::value $confini style.error background $bfg_error_bgcolor]
  if {$val ne ""} {set bfg_error_bgcolor $val}

  # load bookmarks
  if {[::ini::exists $confini bookmarks]} {
    foreach key [::ini::keys $confini bookmarks] {
      dict set bookmarks $key [::ini::value $confini bookmarks $key]
    }
  }

  # close the ini for now
  ::ini::close $confini
}

# generate fonts
foreach fid {widget entry status text mono} {
  set vname [string cat bfg_ $fid font]
  set ffamily [set $vname]
  set fsize [set [string cat $vname size]]
  unset -nocomplain $vname
  font create $vname -family "$ffamily" -size $fsize -weight normal
}

# logic part

# store browser history here
set bfg_history ""
set bfg_histidx 0

# redirection variables for Spartan and Gemini
set redirectcount 0
set redirectlimit 5

# truncate status characters
proc trunc {s} {
  set mlen 60
  set nlen [expr { ($mlen / 2) - 1 }]
  set len [string length $s]
  if {$len > $mlen} {
    # truncate characters in the middle
    set p1 [string range $s 0 $nlen]
    set p2 [string range $s [expr {$len - $nlen}] end]
    return [string cat $p1 "…" $p2]
  } else {return $s}
}

# common request logic:
# 1) connect via TCP (or TLS)
# 2) send a single data chunk with selector etc
# 3) read the incoming data
# 4) close the connection
proc reqresp {host port reqline is_tls encoding} {
  global bfg_response bfg_net_timeout
  if {$is_tls eq 1} {
    set sock [::tls::socket -autoservername true -async $host $port]
  } else {
    set sock [socket -async $host $port]
  }
  global rcv_end_$sock
  unset -nocomplain rcv_end_$sock
  if {$encoding eq ""} {set encoding utf-8}
  fconfigure $sock -translation binary -buffering none -encoding $encoding
  fileevent $sock writable [list connected $sock $reqline]
  proc connected {sock reqline} {
    fileevent $sock writable {}
    puts -nonewline $sock "$reqline"
    flush $sock
    fileevent $sock readable [list rdbl $sock]
  }
  set bfg_response ""
  proc rdbl {sock} {
    global bfg_response rcv_end_$sock
    while {![eof $sock]} {
      append bfg_response [read $sock]
    }
    set rcv_end_$sock 0
  }
  after $bfg_net_timeout "global rcv_end_$sock; set rcv_end_$sock 1"
  vwait rcv_end_$sock
  catch {close $sock}
  if {"$bfg_response" eq ""} {
    set bfg_response "Connection refused or timed out"
  }
  unset -nocomplain rcv_end_$sock
}

# parse target URL
# returns dictionary {scheme host port path handler}
# uses some hacky http-like logic of Tcllib uri module
proc url2dict {inputurl} {
  set out [dict create]
  if [regexp {^(.*)://} $inputurl _ lscheme] {
    dict set out scheme $lscheme
  } else {
    dict set out handler "render_handler_invalid"
    return $out
  }
  set rawout [::uri::split [regsub {^.*://} $inputurl "http://"]]
  set rhost [dict get $rawout host]
  set rpath [dict get $rawout path]
  set rport [dict get $rawout port]
  set secondarydata [dict get $rawout query]
  dict set out host $rhost
  set selector $rpath
  dict set out handler "render_handler_$lscheme"
  # protocol-specific request logic
  switch "$lscheme" {
    gophers -
    gopher {
      if {$rport eq ""} {set rport 70}
      set selector [string cat [string range $rpath 1 end] "\r\n"]
      dict set out handler render_handler_gopher
    }
    finger {
      if {$rport eq ""} {set rport 79}
      set selector "$selector\r\n"
    }
    spartan {
      if {$rport eq ""} {set rport 300}
      if {$rpath eq ""} {set rpath "/"}
      if {![string match "/*" $rpath]} {
        set rpath "/$rpath"
      }
      set blen [string length $secondarydata]
      set selector "$rhost $rpath $blen\r\n$secondarydata"
    }
    nex {
      if {$rport eq ""} {set rport 1900}
      set selector "$selector\r\n"
    }
    gemini {
      if {$rport eq ""} {set rport 1965}
      set selector "$inputurl\r\n"
    }
    default {dict set out handler render_handler_none}
  }
  dict set out path $rpath
  dict set out selector $selector
  dict set out port $rport
  return $out
}

# link clicking logic
set linkcount 0
set curlink 0
# all link tracker 
set linklist ""
# interactive link tracker (prefixes)
set ilinklist ""
proc clicklink {linknum} {
  global bfg_prompt sentry_status linklist ilinklist
  set url [lindex $linklist $linknum]
  set iprefix [lindex $ilinklist $linknum]
  if {$iprefix ne ""} {
    grid .sframe.sentry
    .sframe.sentry state !disabled
    set sentry_status "Prompt from [trunc $url]:"
    focus .sframe.sentry
    vwait bfg_prompt
    .sframe.sentry state disabled
    grid remove .sframe.sentry
    set url "$url$iprefix$bfg_prompt"
    unset -nocomplain bfg_prompt
  }
  urlfetch $url 1
}

# open link in a new window
proc windowlink {linknum} {
  global bfg_prompt sentry_status linklist ilinklist
  global tclpath scriptpath
  set url [lindex $linklist $linknum]
  set iprefix [lindex $ilinklist $linknum]
  if {$iprefix ne ""} {
    grid .sframe.sentry
    .sframe.sentry state !disabled
    set sentry_status "Prompt from [trunc $url]:"
    focus .sframe.sentry
    vwait bfg_prompt
    .sframe.sentry state disabled
    grid remove .sframe.sentry
    set url "$url$iprefix$bfg_prompt"
    unset -nocomplain bfg_prompt
  }
  # forward the URL to a new window
  exec -ignorestderr -- $tclpath $scriptpath $url &
}

# link downloading logic
proc downloadlink {linknum openExternally} {
  global bfg_prompt sentry_status linklist ilinklist 
  global bfg_status bfg_response
  set url [lindex $linklist $linknum]
  set iprefix [lindex $ilinklist $linknum]
  if {$iprefix ne ""} {
    grid .sframe.sentry
    .sframe.sentry state !disabled
    set sentry_status "Prompt from [trunc $url]:"
    focus .sframe.sentry
    vwait bfg_prompt
    .sframe.sentry state disabled
    grid remove .sframe.sentry
    set url "$url$iprefix$bfg_prompt"
    unset -nocomplain bfg_prompt
  }
  # get the raw contents in $bfg_response
  set scheme [urldl $url 1]
  # sanitize the contents for Gemini or Spartan
  if {($scheme eq "spartan") || ($scheme eq "gemini")} {
    regsub {^\d[^\r].*\r\n} $bfg_response "" bfg_response
  }
  # get the last part of the URL as suggested filename
  set uname [file tail $url]
  set outfname [tk_getSaveFile -confirmoverwrite true -initialfile $uname]
  if {$outfname ne ""} {
    set fp [open $outfname w]
    fconfigure $fp -translation binary
    puts -nonewline $fp $bfg_response
    close $fp
    set bfg_response ""
    set bfg_status "Downloaded [trunc $url]"
    after 2000 {set bfg_status Ready}
    if {$openExternally eq 1} {
      extOpen $outfname
    }
  }
}

# link insertion logic
proc linkinsert {textw prevurl rooturl url name iprefix tag} {
  global linkcount linklist ilinklist
  global contentcursor
  global bfg_status bfg_link_fgcolor bfg_link_bgcolor
  set linktext "$url"
  if {$name ne ""} {
    set linktext $name
  }
  set linktext "=> $linktext"
  set tagname "bfglink_$linkcount"
  # resolve the url as local if it doesn't contain a scheme
  if {[::uri::isrelative "$url"]} {
    regexp {^(.*)://} $rooturl _ lscheme
    # case 1: it has 2 slashes in the forward, case 2: it has 1 slash
    # case 3: it has a suffix on the end, case 4: the rest
    if {[string match "//*" "$url"]} {
      set url [string cat "$lscheme" ":" "$url"]
    } elseif {[string match "/*" "$url"]} {
      set url [string cat "$rooturl" "$url"]
    } elseif {[regexp {.*/[^/]+$} "$prevurl"]} {
      set url [string cat "$prevurl" "/../" "$url"]
    } else {
      set url [string cat "$prevurl" "/" "$url"]
    }
    # recanonicalize the URL
    set url [regsub {^http://} [::uri::canonicalize [regsub {^.*://} "$url" "http://"]] "$lscheme://"]
  }
  # handle possible interactive part
  set bindcmd "clicklink $linkcount"
  set bindcmd2 "windowlink $linkcount"
  set bindcmd3 "downloadlink $linkcount 0"
  set bindcmd4 "downloadlink $linkcount 1"
  lappend ilinklist $iprefix
  # perform the insertion
  $textw insert end $linktext "$tagname $tag"
  $textw tag configure $tagname -underline on -foreground $bfg_link_fgcolor -background $bfg_link_bgcolor
  $textw tag bind $tagname <Button-1> $bindcmd
  $textw tag bind $tagname <Shift-Button-1> $bindcmd2
  $textw tag bind $tagname <Button-2> $bindcmd2
  $textw tag bind $tagname <Button-3> $bindcmd3
  $textw tag bind $tagname <Shift-Button-3> $bindcmd4
  $textw tag bind $tagname <Enter> "set prev_status \"\$bfg_status\";set bfg_status [trunc \"$url\"];%W configure -cursor hand2"
  $textw tag bind $tagname <Leave> {
    set bfg_status $prev_status
    %W configure -cursor $contentcursor
  }
  $textw insert end "\n"
  # populate the link list
  lappend linklist $url
  incr linkcount
}

# open unknown protocols in the external OS
proc extOpen {url} {
    global tcl_platform
    if {$tcl_platform(platform) eq "windows"} {
      set command [list {*}[auto_execok start] {}]
      if {[file isdirectory $url]} {
        set url [file nativename [file join $url .]]
      }
    } elseif {$tcl_platform(os) eq "Darwin"} {
      set command [list open]
    } else {
      set command [list xdg-open]
    }
    exec {*}$command $url &
}

# common URL downloader
# return the contents in $bfg_response
proc urldl {inputurl isbinary} {
  set parts [url2dict $inputurl]
  set host [dict get $parts host]
  set port [dict get $parts port]
  set path [dict get $parts path]
  set selector [dict get $parts selector]
  set scheme [dict get $parts scheme]
  set is_tls 0
  if {$scheme eq "gemini"} {set is_tls 1}
  if {$scheme eq "gophers"} {set is_tls 1}
  set encoding "utf-8"
  if {$isbinary eq 1} {set encoding "binary"}
  reqresp $host $port $selector $is_tls $encoding
  return $scheme
}

# common URL fetcher: pass to handler
proc urlfetch {inputurl refhist} {
  set parts [url2dict $inputurl]
  set handler [dict get $parts handler]
  if {$handler eq "render_handler_none"} {
    extOpen $inputurl; # attempt to pass the URL to the external OS
  } elseif {$handler eq "render_handler_invalid"} {
    global linkcount linklist ilinklist curlink bookmarkactive bookmarklabel
    set linkcount 0
    set curlink 0
    set linklist ""
    set ilinklist ""
    .content.text configure -state normal
    .content.text delete 1.0 end; # clear the previous contents
    .content.text insert end "Please enter a valid URL"
    .content.text configure -state disabled
    # append to the history
    if {$refhist eq 1} {histappend "about:invalid"}
    set bookmarkactive "\u2605"
    set bookmarklabel "Add bookmark"
    refreshbookmarks
  } else {
    global bfg_status bfg_response linkcount linklist targeturl
    global bfg_history bfg_histidx curlink ilinklist
    global bookmarks bookmarkactive bookmarklabel
    set bfg_status [trunc "Fetching $inputurl..."]
    set linkcount 0
    set curlink 0
    set linklist ""
    set ilinklist ""
    set scheme [dict get $parts scheme]
    set host [dict get $parts host]
    set port [dict get $parts port]
    set path [dict get $parts path]
    set rooturl "$scheme://$host:$port"
    urldl $inputurl 0
    # append to the history
    if {$refhist eq 1} {histappend $inputurl}
    if {$linkcount > 0} {linkfocus 0 1; set curlink 0}
    set targeturl $inputurl
    wm title . [string cat "BFG - " [trunc $targeturl]]
    # update the bookmark character if the URL is bookmarked
    if {$targeturl in [dict values $bookmarks]} {
      set bookmarkactive "\u2605"
      set bookmarklabel "Remove bookmark"
    } else {
      set bookmarkactive "\u2606"
      set bookmarklabel "Add bookmark"
    }
    set bfg_status [trunc "Rendering $inputurl..."]
    .content.text configure -state normal
    .content.text delete 1.0 end; # clear the previous contents
    $handler "$inputurl" "$rooturl" "$path" "$bfg_response" .content.text
    .content.text configure -state disabled
    refreshbookmarks
    set bfg_status Ready
    focus .content.text
  }
}

# plaintext sanitizer: trim every line end
proc textsanitize {text} {
  set newtext ""
  foreach line [split $text \n] {
    set line [string trimright $line]
    set newtext [string cat $newtext $line "\n"]
  }
  return $newtext
}

# link insertion helper
proc widget_linsert {textw prevurl rooturl linkpart prefix tag} {
  set llist [split [string trim "$linkpart"]]
  set linkurl [lindex $llist 0]
  set linkname ""
  if {[llength $llist] > 1} {
    set linkname [string trim [join [lrange $llist 1 end] " "]]
  }
  linkinsert $textw "$prevurl" "$rooturl" "$linkurl" "$linkname" "$prefix" "$tag"
}

# Gemtext rendering (for Gemini and Spartan)
# Since BFG displays contents in monospace, only three things
# are processed (per the specification):
# links, preformatting (with optional suffixes) and Spartan's input prompts

proc render_gemtext {textw prevurl rooturl gemtext is_spartan} {
  set preformat false
  foreach line [split "$gemtext" "\n"] {
    set line [string trimright "$line"]
    if {[string match "```*" $line]} {; # preformatting mode
      set preformat [expr {!$preformat}]
    } else {
      if {$preformat} {
        $textw insert end "$line\n" preformatter
      } else {
        if {[regexp {^=>(.*)$} $line _ linkpart]} {; # regular link detected
          widget_linsert $textw "$prevurl" "$rooturl" "$linkpart" "" ""
        } elseif {$is_spartan && [regexp {^=:(.*)$} $line _ linkpart]} {; # input link detected
          widget_linsert $textw "$prevurl" "$rooturl" "$linkpart" "?" ""
        } else {$textw insert end "$line\n"}
      }
    }
  }
}

# individual protocol rendering handlers

# finger content is just plain text
proc render_handler_finger {prevurl rooturl path body textw} {
  $textw insert end [textsanitize $body] preformatter
}

# nex content depends on the path:
# with "" or ending in "/", it is plain text with => links
# otherwise, it's just plain text
proc render_handler_nex {prevurl rooturl path body textw} {
  if {$path eq ""} {set path /}
  if {[string index $path end] eq "/"} {
    foreach line [split $body \n] {
      set line [string trimright $line]
      if [regexp {^=>\s(.*)$} $line _ linkpart] {; # link detected
        widget_linsert $textw $prevurl $rooturl $linkpart "" preformatter
      } else {; # normal line
        $textw insert end "$line\n" preformatter
      }
    }
  } else {
    $textw insert end [textsanitize $body] preformatter
  }
}

# gopher content depends on the first character in the selector path
proc render_handler_gopher {prevurl rooturl path body textw} {
  if {($path eq "") || ($path eq "/")} {
    set gophertype 1
    set selector ""
  } else {
    set gophertype [string index $path 0]
    set selector [string range $path 1 end]
  }
  # for now, let's support TSV gophermaps and treat everything else as plaintext
  if {($gophertype eq 1) || ($gophertype eq 7)} {
    # get root url scheme, host and port
    regexp {^(.*)://} $rooturl _ rootscheme
    set parts [::uri::split [regsub {^.*://} $rooturl "http://"]]
    set roothost [dict get $parts host]
    set rootport [dict get $parts port]
    # parse the gophermap body
    foreach line [split $body \n] {
      set fields [split [string trimright $line] \t]
      set l [llength $fields]
      set rtype ""
      set rdesc ""
      set rsel ""
      set rhost ""
      set rport ""
      if {$l > 0} {set rdesc [string trim [lindex $fields 0]]}
      if {$l > 1} {set rsel  [string trim [lindex $fields 1]]}
      if {$l > 2} {set rhost [string trim [lindex $fields 2]]}
      if {$l > 3} {set rport [string trim [lindex $fields 3]]}
      if {[string length $rdesc] > 0} {
        set rtype [string index $rdesc 0]
        set rdesc [string range $rdesc 1 end]
        if {$l < 2} {
          set rsel $rdesc
        }
      }
      # fill in the missing host and port
      if {$rhost eq ""} {set rhost $roothost}   
      if {$rport eq ""} {set rport $rootport}   
      # update the scheme if the resource is the same
      set tscheme gopher
      if {($rhost eq $roothost) && ($rport eq $rootport)} {
        set tscheme $rootscheme
      }
      # now we have resource type, description, selector, host and port
      # let's output it depending on the type and ignore unknown types
      switch $rtype {
        0 -
        1 -
        5 -
        9 { # plain text, gophermap, binary
          linkinsert $textw $prevurl $rooturl "$tscheme://$rhost:$rport/$rtype$rsel" $rdesc "" preformatter
        }
        7 { # gophermap with input
          linkinsert $textw $prevurl $rooturl "$tscheme://$rhost:$rport/$rtype$rsel" $rdesc "\t" preformatter
        }
        8 { # telnet session link
          set username ""
          if {$rsel ne ""} {set username "$rsel@"}
          linkinsert $textw $prevurl $rooturl "telnet://$username$rhost:$rport" $rdesc "" preformatter
        }
        3 { # error message
          $textw insert end "$rdesc\n" {errormsg preformatter}
        }
        i { # info message
          $textw insert end "$rdesc\n" preformatter
        }
        h { # HTTP URL
          regsub ***=URL: $rsel "" clearurl
          linkinsert $textw $prevurl $rooturl [string trim $clearurl] $rdesc "" preformatter
        }
        default {}
      }
    }
  } elseif {($gophertype eq 5) || ($gophertype eq 9)} {
    $textw insert end $body preformatter
  } else {
    $textw insert end [textsanitize $body] preformatter
  }
}

# Spartan has a status line in response and multiple MIME types
# we support only text/gemini and text/plain for now
proc render_handler_spartan {prevurl rooturl path body textw} {
  global redirectcount redirectlimit
  # get the status line
  if {[regexp {^([^\n]*)\n} $body _ statusline]} {
    set statusline [string trimright $statusline]
    set statusparts [split $statusline " "]
    set statuscode [lindex $statusparts 0]
    set statusinfo [join [lrange $statusparts 1 end] " "]
    # reset redirect counter if the code group is not 3
    if {$statuscode ne 3} {set redirectcount 0}
    if {$statuscode eq 2} { # success - get the remaining body
      regsub {.*?\n} $body "" body
      if {[string match "text/gemini*" $statusinfo]} {
        render_gemtext $textw "$prevurl" "$rooturl" "$body" true
      } elseif {[string match "text/plain*" $statusinfo]} {
        $textw insert end [textsanitize $body] preformatter
      } else {
        $textw insert end $body preformatter
      }
    } elseif {$statuscode eq 3} { # redirect
      if {![string match "/*" $statusinfo]} {
        set statusinfo "/$statusinfo"
      }
      set newurl [string cat $rooturl $statusinfo]
      if {$redirectcount < $redirectlimit} {
        incr redirectcount
        urlfetch "$newurl" 0
      }
    } else { # error
      $textw insert end "Error $statuscode: $statusinfo\n"
    }
  } else {
    $textw insert end "Error: empty response from server\n"
  }
}

# Gemini is like Spartan but with a separate input logic
# and relative URL support required
proc render_handler_gemini {prevurl rooturl path body textw} {
  global redirectcount redirectlimit
  if {![string match "/*" "$path"]} {set path "/$path"}
  if {[string match "*/" "$rooturl"]} {set rooturl [string range $rooturl 0 end-1]}
  set baseurl [string cat "$rooturl" "$path"]
  # get the status line
  if {[regexp {^([^\n]*)\n} $body _ statusline]} {
    set statusline [string trimright $statusline]
    set statusparts [split $statusline " "]
    set statuscode [lindex $statusparts 0]
    set mainstatuscode [string index $statuscode 0]
    set statusinfo ""
    if {[llength $statusparts] > 1} {
      set statusinfo [join [lrange $statusparts 1 end] " "]
    }
    if {($statuscode < 10) || ($statuscode > 100)} {
      $textw insert end "Error $statuscode: $statusinfo\n" errormsg
      return
    }
    # reset redirect counter if the code group is not 3
    if {$mainstatuscode ne 3} {set redirectcount 0}
    # we have several code groups
    switch $mainstatuscode {
      1 { # input required
        global sentry_status bfg_prompt
        grid .sframe.sentry
        .sframe.sentry state !disabled
        unset -nocomplain bfg_prompt
        set sentry_status "$statusinfo:"
        focus .sframe.sentry
        vwait bfg_prompt
        .sframe.sentry state disabled
        grid remove .sframe.sentry
        set newurl "$baseurl?$bfg_prompt"
        urlfetch "$newurl" 1
      }
      2 { # success - get the remaining body
        regsub {.*?\n} $body "" body
        if {[string match "text/gemini*" $statusinfo]} {
          render_gemtext $textw "$prevurl" "$rooturl" "$body" true
        } elseif {[string match "text/plain*" $statusinfo]} {
          $textw insert end [textsanitize $body] preformatter
        } else {
          $textw insert end $body preformatter
        }
      }
      3 { # redirect
        if {[::uri::isrelative $statusinfo]} {
          set newurl [string cat $baseurl $statusinfo]
        } else {set newurl $statusinfo}
        if {$redirectcount < $redirectlimit} {
          incr redirectcount
          urlfetch "$newurl" 0
        }
      }
      6 { # client certificate status - not supported yet
        $textw insert end "The server requires a client certificate — not implemented yet\n"
        $textw insert end "Status $statuscode: $statusinfo\n" errormsg 
      }
      default { # error
        $textw insert end "Error $statuscode: $statusinfo\n" errormsg
      }
    }
  } else {
    $textw insert end "Error: empty response from server\n"
  }
}

# history navigation part

proc histappend {inputurl} {
  global bfg_history bfg_histidx
  set prevurl ""
  set previdx [expr {$bfg_histidx - 1}]
  if {$bfg_histidx > 0} {
    set prevurl [lindex $bfg_history $previdx]
  }
  if {$inputurl ne $prevurl} {
    set bfg_history [lrange $bfg_history 0 $previdx]
    lappend bfg_history $inputurl
    incr bfg_histidx
    .ctrl.back configure -state normal
    .ctrl.fwd configure -state disabled
  }
}

proc goback {} {
  global bfg_history bfg_histidx targeturl
  if {$bfg_histidx > 0} {
    set newurl [lindex $bfg_history [expr {$bfg_histidx - 2}]]
    if {($newurl ne "") && ($newurl ne $targeturl)} {
      incr bfg_histidx -1
      urlfetch "$newurl" 0
      .ctrl.fwd configure -state normal
      if {$bfg_histidx < 2} {
        .ctrl.back configure -state disabled
      }
    }
  } else {
    .ctrl.back configure -state disabled
  }
}

proc goforward {} {
  global bfg_history bfg_histidx targeturl
  set newurl [lindex $bfg_history $bfg_histidx]
  if {($newurl ne "") && ($newurl ne $targeturl)} {
    incr bfg_histidx
    urlfetch "$newurl" 0
    .ctrl.back configure -state normal
    if {$bfg_histidx >= [llength $bfg_history]} {
      .ctrl.fwd configure -state disabled
    }
  }
}

# in-page text search functionality
set cursearchidx "1.0"
set cursearchpattern ""
proc textsearch {pattern dir isregex} {
  global cursearchidx cursearchpattern
  global bfg_highlight_bgcolor bfg_highlight_fgcolor
  if {("$pattern" eq "") && ("$cursearchpattern" ne "")} {
    set pattern "$cursearchpattern"
  }
  if {("$pattern" ne "$cursearchpattern") && ("$pattern" ne "")} {
    set cursearchidx "1.0"
  }
  set mode {-exact}
  if {$isregex} {set mode {-regexp}}
  set numdir [expr {int($dir)}]
  if {$dir eq -1} {
    set dir {-backwards}
  } else {set dir {-forwards}}
  set fcount 0
  set foundidx [.content.text search $mode $dir -nocase -count fcount $pattern $cursearchidx]
  .content.text tag delete highlight
  if {$foundidx ne ""} {
    # add search highlight tag
    set endidx "$foundidx + $fcount chars"
    .content.text tag add highlight $foundidx $endidx
    .content.text tag configure highlight -background $bfg_highlight_bgcolor -foreground $bfg_highlight_fgcolor
    .content.text see $foundidx
    set cursearchidx "$foundidx + $numdir chars"
    set cursearchpattern "$pattern"
  } else {set cursearchidx "1.0"}
}

# search GUI action
proc searchui {dir} {
  global cursearchidx cursearchpattern
  global sentry_status bfg_status bfg_prompt bfg_entry
  set prevstatus "$bfg_status"
  grid .sframe.sentry
  .sframe.sentry state !disabled
  unset -nocomplain bfg_prompt
  set sentry_status "Search:"
  set bfg_entry 1
  if {$dir eq -1} {
    set sentry_status "Search backwards:"
  }
  set bfg_status $sentry_status
  focus .sframe.sentry
  vwait bfg_prompt
  .sframe.sentry state disabled
  grid remove .sframe.sentry
  set bfg_entry 0
  textsearch "$bfg_prompt" $dir 0
  set bfg_status "$prevstatus"
  unset -nocomplain bfg_prompt
}

# Bookmark logic
proc addremovebookmark {url} {
  global bookmarks bookmarklabel bookmarkactive
  global sentry_status bfg_status bfg_rawprompt bfg_prompt bfg_entry
  set urlkey ""
  dict for {bkey bval} $bookmarks {
    if {$bval eq $url} {
      set urlkey $bkey
    }
  }
  if {$urlkey ne ""} { # found the URL, removing the bookmark
    set bookmarks [dict remove $bookmarks $urlkey]
    set bookmarkactive "\u2606"
    set bookmarklabel "Add bookmark"
  } else { # adding a new bookmark
    set prevstatus "$bfg_status"
    grid .sframe.sentry
    .sframe.sentry state !disabled
    unset -nocomplain bfg_prompt
    set sentry_status "Bookmark name:"
    set bfg_entry 1
    set bfg_status $sentry_status
    set bfg_rawprompt $url
    focus .sframe.sentry
    .sframe.sentry selection range 0 end
    vwait bfg_prompt
    .sframe.sentry state disabled
    grid remove .sframe.sentry
    set bfg_entry 0
    # we have the name in bfg_prompt
    set bname [string trim $bfg_prompt]
    dict set bookmarks $bname $url
    set bookmarkactive "\u2605"
    set bookmarklabel "Remove bookmark"
    unset -nocomplain bfg_prompt
    set bfg_status "$prevstatus"
    set sentry_status ""
  }
  savebookmarks
  refreshbookmarks
}

# save the bookmarks in the configuration INI
proc savebookmarks {} {
  global config_file bookmarks
  set confini [::ini::open $config_file -encoding utf-8]
  ::ini::delete $confini bookmarks
  dict for {bkname bkurl} $bookmarks {
    ::ini::set $confini bookmarks $bkname $bkurl
  }
  ::ini::commit $confini
  ::ini::close $confini
}

# build or refresh bookmark menu
proc refreshbookmarks {} {
  global bookmarklabel bookmarks targeturl
  .ctrl.bkm.menu delete 0 end
  .ctrl.bkm.menu add command -label "$bookmarklabel" -command {addremovebookmark $targeturl}
  .ctrl.bkm.menu add separator
  dict for {bkname bkurl} $bookmarks {
    .ctrl.bkm.menu add command -label "$bkname" -command "urlfetch $bkurl 1"
  }
}

# UI part

set contentcursor "left_ptr"
set targeturl ""
if {$argc > 0} {
  set targeturl [lindex $argv 0]
}

# set the window title
wm title . "BFG"

# set the window geometry
wm minsize . 800 600

# control bar
set btnwidth 2
set btnpad 2
ttk::frame .ctrl -padding 4
# change this to 2605 when active
set bookmarkactive "\u2606"
set bookmarklabel "Add bookmark"
grid [ttk::button .ctrl.back -text "↩" -width $btnwidth -style bfg.TButton -command {goback}] \
  -row 0 -column 0 -sticky nes -padx $btnpad
grid [ttk::button .ctrl.fwd -text "↪️" -width $btnwidth -style bfg.TButton -command {goforward}] \
  -row 0 -column 1 -sticky nes -padx $btnpad
grid [ttk::button .ctrl.refresh -text "↻" -width $btnwidth -style bfg.TButton -command {urlfetch "$targeturl" 0}] \
  -row 0 -column 2 -sticky nes -padx $btnpad
grid [ttk::entry .ctrl.addr -textvariable targeturl -width 40 -font bfg_entryfont] -row 0 -column 3 -sticky nswe -ipadx $btnpad
grid [ttk::menubutton .ctrl.bkm -textvariable bookmarkactive -style bfg.TButton -width $btnwidth -menu .ctrl.bkm.menu] \
  -row 0 -column 4 -sticky nws -padx $btnpad
grid columnconfigure .ctrl 3 -weight 1

# bookmarks menu
menu .ctrl.bkm.menu -tearoff 0 -cursor $contentcursor
refreshbookmarks

# main content widget
ttk::frame .content
tk::text .content.text -cursor $contentcursor -yscrollcommand ".content.yscroll set" -wrap word \
  -font bfg_textfont -foreground $bfg_main_fgcolor -background $bfg_main_bgcolor -state disabled
ttk::scrollbar .content.yscroll -orient vertical -command ".content.text yview"
grid .content.text -column 0 -row 0 -sticky nsew
grid .content.yscroll -column 1 -row 0 -sticky ns
grid columnconfigure .content 0 -weight 1
grid rowconfigure .content 0 -weight 1

# status bar
ttk::frame .sframe
ttk::label .sframe.status -padding 4 -textvariable bfg_status -font bfg_statusfont
ttk::entry .sframe.sentry -textvariable bfg_rawprompt -state disabled -font bfg_entryfont
grid .sframe.status -column 0 -row 0 -sticky nsew
grid .sframe.sentry -column 1 -row 0 -sticky nsw
grid columnconfigure .sframe 0 -weight 1
set bfg_status Ready

# place them all
grid .ctrl -column 0 -row 0 -sticky nsew
grid .content -column 0 -row 1 -sticky nsew
grid .sframe -column 0 -row 2 -sticky nsew 
grid remove .sframe.sentry

# root grid geometry: don't resize the top and bottom row
grid rowconfigure . 1 -weight 1
grid columnconfigure . 0 -weight 1

# iterate over available platform-dependent themes, apply "clam" if none found
catch {ttk::style theme use clam}
catch {ttk::style theme use aqua}
catch {ttk::style theme use winnative}
catch {ttk::style theme use $bfg_theme}

# apply custom styles
ttk::style configure bfg.TButton -font bfg_widgetfont

# set up keybindings

# address entry
bind .ctrl.addr <Return> {urlfetch "$targeturl" 1}
bind .ctrl.addr <FocusIn> {set bfg_entry 1; .ctrl.addr selection range 0 end}
bind .ctrl.addr <FocusOut> {set bfg_entry 0; .ctrl.addr selection clear}
focus .ctrl.addr

# scroll and focus into the numbered link
proc linkfocus {lnum noscroll} {
  global bfg_focusedlink_fgcolor bfg_focusedlink_bgcolor
  # scroll into the link
  set ci [lindex [.content.text tag ranges "bfglink_$lnum"] 0]
  if {$noscroll eq 0} {
    .content.text see $ci
  }
  # add highlight tag
  set rng [string cat [lindex [split $ci .] 0] ".end"]
  .content.text tag delete focuslink
  .content.text tag add focuslink $ci $rng
  .content.text tag configure focuslink -foreground $bfg_focusedlink_fgcolor -background $bfg_focusedlink_bgcolor
}

# do this on startup
if {$targeturl ne ""} {
  .ctrl.addr selection clear
  urlfetch "$targeturl" 1
}
set bfg_entry 0
set bfg_rawprompt ""
.ctrl.back configure -state disabled
.content.text tag configure errormsg -foreground $bfg_error_fgcolor -background $bfg_error_bgcolor
.content.text tag configure preformatter -font bfg_monofont

# general keybinding switch

bind . <Key> {
  if {$bfg_entry eq 0} {
    switch "%K" {
      g {focus .ctrl.addr}
      F5 -
      r {urlfetch "$targeturl" 0}
      default {}
      b {goback}
      f {goforward}
      Prior -
      Left -
      h {.content.text yview scroll -1 pages}
      Next -
      Right -
      l {.content.text yview scroll 1 pages}
      Down -
      j {.content.text yview scroll 1 units}
      Up -
      k {.content.text yview scroll -1 units}
      a { # select previous link
        if {$linkcount > 0} { # we have some links
          incr curlink -1
          if {$curlink < 0} {
            set curlink [expr {$linkcount - 1}]
          }
          linkfocus $curlink 0
          set vurl [lindex $linklist $curlink]
          set bfg_status "=> [trunc $vurl]"
        }
      }
      s { # select next link
        if {$linkcount > 0} { # we have some links
          incr curlink
          if {$curlink >= $linkcount} {
            set curlink 0
          }
          linkfocus $curlink 0
          set vurl [lindex $linklist $curlink]
          set bfg_status "=> [trunc $vurl]"
        }
      }
      space -
      Return { # visit the focused link
        if {$linkcount > 0} { # we have some links
          .content.text tag delete focuslink
          clicklink $curlink
        }
      }
      d { # download the focused link
        if {$linkcount > 0} { # we have some links
          downloadlink $curlink 0
        }
      }
      D { # download the focused link and open it externally
        if {$linkcount > 0} { # we have some links
          downloadlink $curlink 1
        }
      }
      Escape { # reset search highlights
        set cursearchpattern ""
        set cursearchidx "1.0"
        .content.text tag delete highlight
      }
      slash {searchui 1}
      default {}
    }
  }
}

bind . <Shift-space> {
  if {$linkcount > 0} { # we have some links
    windowlink $curlink
  }
}

bind . <Shift-Return> {
  if {$linkcount > 0} { # we have some links
    windowlink $curlink
  }
}

# generic mouse click events
# 1 - left, 2 - mid, 3 - right, 8 - back, 9 - forward
bind . <Button> {
  if {$bfg_entry eq 0} {
    switch "%b" {
      8 {goback}
      9 {goforward}
      default {}
    }
  }
}

# status entry
bind .sframe.sentry <Return> {
  set bfg_prompt "$bfg_rawprompt"
  set bfg_rawprompt ""
}
bind .sframe.sentry <Enter> {
  if {$sentry_status ne ""} {
    set bfg_status [trunc "$sentry_status"]
  }
}
bind .sframe.sentry <FocusIn> {
  set bfg_entry 1
  if {$sentry_status ne ""} {
    set bfg_status [trunc "$sentry_status"]
  }
}
bind .sframe.sentry <FocusOut> {
  set bfg_entry 0
}

# search
bind . <Control-f> {searchui 1}
bind . <Control-F> {searchui -1}
bind . <Control-slash> {searchui -1}

# bookmark menu
bind . <Control-b> {event generate .ctrl.bkm <Button-1>}

# exit
bind . <Control-q> {exit 0}