#!/usr/bin/tclsh

# idlebiff: check for new mail in an IMAP account using IDLE extension
#           the notifications arrives as soon as there is new mail
# Copyright (C) 2016 Enrique D. Bosch 'presi'

# idlebiff is based on the ideas of xbiff and imapbiff but the code is 
# entirely rewritten

#    This program is free software: you can redistribute it and/or modify
#    it under the terms of the GNU General Public License as published by
#    the Free Software Foundation, either version 3 of the License, or
#    (at your option) any later version.
#
#    This program is distributed in the hope that it will be useful,
#    but WITHOUT ANY WARRANTY; without even the implied warranty of
#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#    GNU General Public License for more details.
#
#    You should have received a copy of the GNU General Public License
#    along with this program.  If not, see <http://www.gnu.org/licenses/>.

package require Tk
package require crc32
package require tkpng
package require png
package require tooltip

namespace path ::tcl::mathop
proc or args { foreach x $args { if { $x } { return 1 } }; return 0 }
proc and args { foreach x $args { if { $x } continue  { return 0 } }; return 1 }

proc setappend { var args } { upvar 1 $var v; set v [ join $args {} ] }

proc check_conf_and_set_default { opt default } \
{
  variable ::shared::conf

  if {![ info exists conf($opt) ]} { set conf($opt) $default }
}

namespace eval static \
{
  variable ntag 1
  variable ccsp 0
  variable pmsgs 0
  variable search_resp 0
  array set ccsu {}
}

namespace eval shared \
{
  variable idle 0
  array set cap \
  {
    logindisabled 0
    logindisabled_chk 0
    chk 0
    idle 0
    esearch 0
  }
  variable search
  variable rexp_chk
  variable rexpsearch
  variable sock
  variable conf
  array set conf {}
  variable tevent
  array set tevent {}
  variable teidi 0
  variable teidf 0
  variable ka 0
  variable img_up
  variable img_down
  variable img_chk
  variable new_messages 0
  variable tag
}

proc define_pixmaps {} \
{
  variable ::shared::img_up
  variable ::shared::img_down
  variable ::shared::img_chk
  variable ::shared::conf

  set img_up [ image create photo -format png -file $conf(png_up) ]
  set img_down [ image create photo -format png -file $conf(png_down) ]
  set img_chk [ image create photo -format png -file $conf(png_chk) ]
}

proc icon {} \
{
  variable ::shared::img_up
  variable ::shared::img_down
  variable ::shared::img_chk
  variable ::shared::conf

  set pnginfo [ ::png::imageInfo $conf(png_up) ]
  set png_up_w [ dict get $pnginfo width ]
  set png_up_h [ dict get $pnginfo height ]

  set pnginfo [ ::png::imageInfo $conf(png_down) ]
  set png_down_w [ dict get $pnginfo width ]
  set png_down_h [ dict get $pnginfo height ]

  set pnginfo [ ::png::imageInfo $conf(png_chk) ]
  set png_chk_w [ dict get $pnginfo width ]
  set png_chk_h [ dict get $pnginfo height ]

  set size_not_same [ or [ != $png_up_w $png_down_w ] [ != $png_down_w $png_chk_w ] [ != $png_up_h $png_down_h ] [ != $png_down_h $png_chk_h ] ]
  if { $size_not_same } { emit_error size }

  wm title . idlebiff
  wm iconname . idlebiff
  append geom [ + $png_up_w 10 ] x [ + $png_up_h 10 ]
  if {[ and $conf(pos_x) $conf(pos_y) ]} { append geom + $conf(pos_x) + $conf(pos_y) }
  wm geometry . $geom
  wm resizable . 0 0
  wm overrideredirect . $conf(nodecor)

  frame .frame
  pack .frame -expand 1 -fill both
  canvas .frame.canvas -width $png_up_w -height $png_up_h -bd 10 -relief sunken
  pack .frame.canvas -expand 1 -fill both

  define_pixmaps

  button .frame.canvas.button -image $img_chk -cursor left_ptr
  .frame.canvas create window 0 0 -window .frame.canvas.button -anchor nw 
  pack .frame.canvas.button -expand 1 -fill both

  bind .frame.canvas.button <Button-1> force_down
  bind .frame.canvas.button <Button-2> { cleanup $con }
  bind .frame.canvas.button <Button-3> { idle_cycle $con 1 }
}

proc get_password bad \
{
  variable ::shared::conf
  upvar #0 pass pass

  if { $bad } { set textbad "WRONG PASSWORD\n" } \
  else { set textbad {} }
  if { !$conf(tls) } { set nv "\nWARNING: INSECURE CONNECTION" }
  
  toplevel .tl
  wm title .tl {idlebiff: password}
  message .tl.msg -bg black -fg yellow -width 400 -justify center \
          -text "${textbad}Enter password for\n$conf(user) at $conf(host)"
  pack .tl.msg -side top -fill both
  entry .tl.entry -relief sunken -bg grey -fg black -width 30 -show *
  pack .tl.entry -side top
  button .tl.bok -text OK -padx 20 -command { set pass [ .tl.entry get ]; destroy .tl }
  pack .tl.bok -side right
  bind .tl.entry <Return> { .tl.bok invoke }
  button .tl.bc -text Cancel -command { cleanup $con } -padx 20
  pack .tl.bc -side left
  focus .tl.entry
  vwait pass
  set p $pass
  unset pass
  return $p
}

proc update_img img \
{
  variable ::shared::conf
  variable ::shared::new_messages

  .frame.canvas.button configure -image $img
  if { $conf(tip) } { tooltip::tooltip .frame.canvas $new_messages }
}

proc read_conf {} \
{
  upvar #0 argv arg argc argn
  variable ::shared::conf

  if {[ == $argn 1 ]} { set config $arg } else { set config "$::env(HOME)/.idlebiffrc" }
  set cf [ open $config ]
  while {[ >= [ gets $cf lin ] 0 ]} \
  {
    if {[ == [ string index [ string trim $lin ] 0 ] # ]} continue
    set lconf [ split $lin = ]
    set val [ join [ lassign $lconf key ] = ]
    set conf([ string trim $key]) [ string trim $val ]
  }
}

proc set_params {} \
{
  variable ::shared::rexp_chk

  check_conf_and_set_default criteria UNSEEN
  check_conf_and_set_default nodecor 1
  check_conf_and_set_default tip 0
  check_conf_and_set_default tls 0
  check_conf_and_set_default tls_validate_cert 1
  check_conf_and_set_default initial_noop 0
  check_conf_and_set_default imap_trace 0
  set rexp_chk {(?: |\[)capability }
}

proc set_search_params {} \
{
  variable ::shared::cap
  variable ::shared::search
  variable ::shared::rexpsearch
  variable ::shared::conf

  if { $cap(esearch) } \
  {
    set search "SEARCH RETURN (COUNT) $conf(criteria)"
    set rexpsearch {^\* esearch \(tag [^)]*\) count (.*)$}
  } \
  else \
  {
    set search "SEARCH $conf(criteria)"
    set rexpsearch {^\* search((?: .*|$))}
  }
}

proc emit_error args { error $args }

proc set_timeout {} \
{
  variable ::shared::conf
  variable ::shared::tevent
  variable ::shared::teidf

  set tevent($teidf) [ after ${conf(timeout)}000 \
                       {
                         update_img $::shared::img_chk
                         cancel_timeout
                         close $con
                         init
                       } \ 
                     ]
  incr teidf  
}

proc cancel_timeout {} \
{
  variable ::shared::tevent
  variable ::shared::teidi

  if {[ info exists tevent($teidi) ]} \
  {
    after cancel $tevent($teidi)
    unset tevent($teidi)
    incr teidi
  }
}

proc exec_terse { com args } \
{
  if {[ catch { set res [ eval "$com [ join $args]" ] } ]} \
  {
    set terse [ split $::errorInfo "\n" ]
    puts [ join [ lrange $terse 0 0 ] ]
    exit 1
  }
  return $res
}

proc recon con \
{
  variable ::shared::ka
  variable ::shared::idle
  variable ::shared::img_chk

  after cancel $ka
  update_img $img_chk
  set idle 0
  catch { close $con }
  after 3000 init
}

proc imap_command { con com } \
{
  variable ::shared::conf

  if { $conf(imap_trace) } \
  { if {[ regexp {.*LOGIN.*} $com ]} { puts "C: [string range $com 0 10]" } else { puts "C: $com" } }

  set r [ catch { puts $con $com } ]
  if {[ eq $com LOGOUT ]} return
  if { $r } \
  {
    recon $con
    return
  }
  set_timeout
}

proc imap_command_tagged { con com { prefix A } } \
{
  variable ::static::ntag
  variable ::shared::tag

  if {[ == $ntag 10000 ]} { set ntag 1 }
  setappend tag $prefix [ format %04d $ntag ]
  append tcom $tag { } $com
  imap_command $con $tcom
  incr ntag
}

proc ok_tagged { linea { tag {A\d+} } } \
{
  append rexp {^} $tag { ok.*$}
  return [ regexp -lineanchor -nocase $rexp $linea ]
}

proc ok_untagged linea \
{
  return [ regexp -lineanchor -nocase {^\* ok.*$} $linea ]
}

proc no_tagged linea \
{
  return [ regexp -lineanchor -nocase {^A\d+ no.*$} $linea ]
}

proc login { con retr } \
{
  variable ::shared::conf
  variable ::shared::cap

  if { $cap(logindisabled) } { emit_error logindisabled }

  if { $retr } { unset conf(pass) }
  if { ![ info exists conf(pass) ] } { set conf(pass) [ get_password $retr ] }

  imap_command_tagged $con "LOGIN $conf(user) $conf(pass)"
}

proc logout con \
{
  variable ::shared::conf

  fileevent $con readable { parse_logout $con }
  after ${conf(timeout_logout)}000 \
  {
    close $con
    exit 0
  }
  imap_command_tagged $con LOGOUT
}

proc cleanup con \
{
  variable ::shared::ka
  variable ::shared::img_chk
  variable ::shared::idle

  update_img $img_chk
  after cancel $ka
  if { $idle } { exit_idle $con }
  logout $con
}

proc force_down {} \
{
  variable ::shared::img_down

  update_img $img_down
}

proc enter_idle con \
{
  imap_command_tagged $con IDLE
}

proc exit_idle con \
{
  variable ::shared::idle

  set idle 0
  imap_command $con DONE
}

proc enter_mailbox con \
{
  variable ::shared::conf

  imap_command_tagged $con "EXAMINE $conf(mailbox)"
}

proc exit_mailbox con \
{
  imap_command_tagged $con CLOSE
}

proc do_search con \
{
  variable ::shared::search
  variable ::shared::img_chk

  update_img $img_chk
  imap_command_tagged $con $search
}

proc check_cap { linea args } \
{
  variable ::shared::cap
  variable ::shared::rexp_chk

  if {[ regexp -nocase -lineanchor $rexp_chk $linea ]} \
  {
    if {[ eq $args logindisabled ]} { set cap(logindisabled_chk) 1 } \
    else { set cap(chk) 1 }
    foreach capname $args \
    {
      if { !$cap($capname) } \
      {
        set rexp_cap " ${capname}(?: |]|$)"
        set cap($capname) [ regexp -nocase -lineanchor $rexp_cap $linea ]
      }
    }
  }
}

proc idle_cycle { con check } \
{
  variable ::shared::conf
  variable ::shared::ka

  after cancel $ka
  exit_idle $con
  if { $check } { do_search $con } \
  else { enter_idle $con }
  set ka [ after ${conf(keepalive)}000 { idle_cycle $con 0 } ]
}

proc init_idle con \
{
  variable ::shared::conf
  variable ::shared::ka
  variable ::shared::cap

  if { !$cap(idle) } { emit_error noidle }
  fileevent $con readable { parse_idle_check $con }
  enter_mailbox $con
  set_search_params
  do_search $con
  set ka [ after ${conf(keepalive)}000 { idle_cycle $con 0 } ]
}

proc parse_greeting con \
{
  variable ::shared::cap

  set linea [ read_line $con ]
  check_cap $linea logindisabled
  if {[ ok_untagged $linea ]} \
  {
    if { $cap(logindisabled_chk) } \
    {
      fileevent $con readable { parse_login $con }
      login $con 0
    } \
    else \
    {
      fileevent $con readable { parse_logindisabled $con }
      imap_command_tagged $con CAPABILITY
    }
  }
}

proc parse_logindisabled con \
{
  variable ::shared::cap

  set linea [ read_line $con ]
  check_cap $linea logindisabled
  if {[ ok_tagged $linea ]} \
  {
    if { $cap(logindisabled_chk) } \
    {
      fileevent $con readable { parse_login $con }
      login $con 0
    }
  }
}

proc parse_login con \
{
  variable ::shared::cap

  set linea [ read_line $con ]
  check_cap $linea idle esearch
  if {[ ok_tagged $linea ]} \
  {
    if { $cap(chk) } { init_idle $con } \
    else \
    {
      fileevent $con readable { parse_cap $con }
      imap_command_tagged $con CAPABILITY
    }
  } \
  elseif {[ no_tagged $linea ]} { login $con 1 }
}

proc parse_cap con \
{
  set linea [ read_line $con ]
  check_cap $linea idle esearch
  if {[ ok_tagged $linea ]} { init_idle $con }
}

proc parse_idle_check con \
{
  variable ::shared::idle
  variable ::shared::ka
  variable ::shared::conf

  if {[ catch { set linea [ read_line $con ] } ]} return
  set prim [ string range $linea 0 0 ]
  if {[ eq $prim + ]} { set idle 1 } \
  elseif { $idle } \
  {
    if {[ eq $prim * ]} \
    {
      if {[ ok_untagged $linea ]} \
      {
        after cancel $ka
        set ka [ after ${conf(keepalive)}000 { idle_cycle $con 0 } ]
      } \
      else { idle_cycle $con 1 } \
    } \
  } \
  else { parse_search $con $linea }
}

proc parse_search { con linea } \
{
  variable ::shared::conf
  variable ::shared::img_up
  variable ::shared::img_down
  variable ::shared::new_messages
  variable ::shared::cap
  variable ::shared::rexpsearch
  variable ::static::pmsgs
  variable ::static::search_resp

  if {[ regexp -lineanchor -nocase $rexpsearch $linea -> res ]} \
  {
    if { $cap(esearch) } { set pmsgs $res } else { incr pmsgs [ llength $res ] }
    set search_resp 1
  }
  if {[ and $search_resp [ ok_tagged $linea ] ]} \
  {
    enter_idle $con
    set new_messages $pmsgs
    set pmsgs 0
    set search_resp 0
    if {[ > $new_messages 0 ]} \
         { set current $img_up } \
    else { set current $img_down }
    update_img $current
  }
  if {[ no_tagged $linea ]} { emit_error search }
}

proc parse_logout con \
{
  variable ::shared::conf
  variable ::shared::tag

  if {[ catch { gets $con linea } ]} return
  if { $conf(imap_trace) } { puts "S: $linea" }
  if {[ ok_tagged $linea $tag ]} \
  {
    close $con
    exit 0
  }
}

proc read_line con \
{
  variable ::shared::conf

  cancel_timeout
  if {[ catch { set r [ gets $con line ] } ]} \
  {
    recon $con
    return -code error
  }
  if {[ regexp -lineanchor -nocase {^\* bye(?: .*|$)} $line ]} \
  {
    recon $con
    return -code error
  }
  if {[ and [ < $r 1 ] [ eof $con ] ]} \
  {
    recon $con
    return -code error
  } \
  else \
  {
    if { $conf(imap_trace) } { puts "S: $line" }

    return $line
  }
}

proc parse_cert_subject sub \
{
  set cst [ split [ string map { , = / = } $sub ] = ]
  foreach v $cst { lappend cstp [ string trim $v ] }
  return $cstp
}

proc tls_cb { type channel depth cert status error } \
{
  variable ::shared::conf
  variable ::static::ccsu
  variable ::static::ccsp

  array set ca $cert
  if {[ info exists conf(tls_ca_subject) ]} \
  {
    if {[ and [ ne $conf(tls_ca_subject) {} ] [ eq $type verify ] [ eq $ca(subject) $ca(issuer) ] ]} \
    {
      array set csu [ parse_cert_subject $ca(subject) ]
      if { !$ccsp } \
      {
        array set ccsu [ parse_cert_subject $conf(tls_ca_subject) ]
        set ccsp 1
      }
      foreach i [ array names ccsu ] \
      {
        if { ![ info exists csu($i) ] } { emit_error cert }
        if {[ ne $csu($i) $ccsu($i) ]} { emit_error cert }
      }
    }
  }
}

proc init_tls {} \
{
  variable ::shared::conf
  variable ::shared::sock

  if { $conf(tls) } \
  {
    set tlsv [ package require tls ]
    if {[ >= $tlsv 1.6.4 ]} { set tls1x {-tls1.1 1 -tls1.2 1} } \
    else { set tls1x {} }
    if {[ info exists conf(sni) ]} { set sni "-servername $conf(sni)" } \
    else { set sni {} }
    set sock "::tls::socket -ssl2 0 -ssl3 0 -tls1 1 $tls1x \
      -cafile   \"$conf(tls_ca_file)\" \
      -cadir    \"$conf(tls_ca_dir)\" \
      -certfile \"$conf(tls_client_cert)\" \
      -keyfile  \"$conf(tls_client_key)\" \
      -request  \"$conf(tls_validate_cert)\" \
      -require  \"$conf(tls_validate_cert)\" \
      -cipher   \"$conf(tls_ciphers)\" \
      $sni \
      -command  tls_cb"
  } \
  else { set sock socket }
}

proc init {} \
{
  upvar #0 con con
  variable ::shared::conf
  variable ::shared::sock

  set con [ exec_terse $sock -async $conf(host) $conf(port) ]
  fconfigure $con -blocking 0 -buffering line -translation {crlf crlf}
  fileevent $con readable { parse_greeting $con }
  if { $conf(initial_noop) } { imap_command_tagged $con NOOP N }
}

read_conf
set_params
icon
init_tls
init

vwait forever