1 #!/usr/bin/tclsh
  2 
  3 # idlebiff: check for new mail in an IMAP account using IDLE extension
  4 #           the notifications arrives as soon as there is new mail
  5 # Copyright (C) 2016 Enrique D. Bosch 'presi'
  6 
  7 # idlebiff is based on the ideas of xbiff and imapbiff but the code is 
  8 # entirely rewritten
  9 
 10 #    This program is free software: you can redistribute it and/or modify
 11 #    it under the terms of the GNU General Public License as published by
 12 #    the Free Software Foundation, either version 3 of the License, or
 13 #    (at your option) any later version.
 14 #
 15 #    This program is distributed in the hope that it will be useful,
 16 #    but WITHOUT ANY WARRANTY; without even the implied warranty of
 17 #    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 18 #    GNU General Public License for more details.
 19 #
 20 #    You should have received a copy of the GNU General Public License
 21 #    along with this program.  If not, see <http://www.gnu.org/licenses/>.
 22 
 23 package require Tk
 24 package require crc32
 25 package require tkpng
 26 package require png
 27 package require tooltip
 28 
 29 namespace path ::tcl::mathop
 30 proc or args { foreach x $args { if { $x } { return 1 } }; return 0 }
 31 proc and args { foreach x $args { if { $x } continue  { return 0 } }; return 1 }
 32 
 33 proc setappend { var args } { upvar 1 $var v; set v [ join $args {} ] }
 34 
 35 proc check_conf_and_set_default { opt default } \
 36 {
 37   variable ::shared::conf
 38 
 39   if {![ info exists conf($opt) ]} { set conf($opt) $default }
 40 }
 41 
 42 namespace eval static \
 43 {
 44   variable ntag 1
 45   variable ccsp 0
 46   variable pmsgs 0
 47   variable search_resp 0
 48   array set ccsu {}
 49 }
 50 
 51 namespace eval shared \
 52 {
 53   variable idle 0
 54   array set cap \
 55   {
 56     logindisabled 0
 57     logindisabled_chk 0
 58     chk 0
 59     idle 0
 60     esearch 0
 61   }
 62   variable search
 63   variable rexp_chk
 64   variable rexpsearch
 65   variable sock
 66   variable conf
 67   array set conf {}
 68   variable tevent
 69   array set tevent {}
 70   variable teidi 0
 71   variable teidf 0
 72   variable ka 0
 73   variable img_up
 74   variable img_down
 75   variable img_chk
 76   variable new_messages 0
 77   variable tag
 78 }
 79 
 80 proc define_pixmaps {} \
 81 {
 82   variable ::shared::img_up
 83   variable ::shared::img_down
 84   variable ::shared::img_chk
 85   variable ::shared::conf
 86 
 87   set img_up [ image create photo -format png -file $conf(png_up) ]
 88   set img_down [ image create photo -format png -file $conf(png_down) ]
 89   set img_chk [ image create photo -format png -file $conf(png_chk) ]
 90 }
 91 
 92 proc icon {} \
 93 {
 94   variable ::shared::img_up
 95   variable ::shared::img_down
 96   variable ::shared::img_chk
 97   variable ::shared::conf
 98 
 99   set pnginfo [ ::png::imageInfo $conf(png_up) ]
100   set png_up_w [ dict get $pnginfo width ]
101   set png_up_h [ dict get $pnginfo height ]
102 
103   set pnginfo [ ::png::imageInfo $conf(png_down) ]
104   set png_down_w [ dict get $pnginfo width ]
105   set png_down_h [ dict get $pnginfo height ]
106 
107   set pnginfo [ ::png::imageInfo $conf(png_chk) ]
108   set png_chk_w [ dict get $pnginfo width ]
109   set png_chk_h [ dict get $pnginfo height ]
110 
111   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 ] ]
112   if { $size_not_same } { emit_error size }
113 
114   wm title . idlebiff
115   wm iconname . idlebiff
116   append geom [ + $png_up_w 10 ] x [ + $png_up_h 10 ]
117   if {[ and $conf(pos_x) $conf(pos_y) ]} { append geom + $conf(pos_x) + $conf(pos_y) }
118   wm geometry . $geom
119   wm resizable . 0 0
120   wm overrideredirect . $conf(nodecor)
121 
122   frame .frame
123   pack .frame -expand 1 -fill both
124   canvas .frame.canvas -width $png_up_w -height $png_up_h -bd 10 -relief sunken
125   pack .frame.canvas -expand 1 -fill both
126 
127   define_pixmaps
128 
129   button .frame.canvas.button -image $img_chk -cursor left_ptr
130   .frame.canvas create window 0 0 -window .frame.canvas.button -anchor nw 
131   pack .frame.canvas.button -expand 1 -fill both
132 
133   bind .frame.canvas.button <Button-1> force_down
134   bind .frame.canvas.button <Button-2> { cleanup $con }
135   bind .frame.canvas.button <Button-3> { idle_cycle $con 1 }
136 }
137 
138 proc get_password bad \
139 {
140   variable ::shared::conf
141   upvar #0 pass pass
142 
143   if { $bad } { set textbad "WRONG PASSWORD\n" } \
144   else { set textbad {} }
145   if { !$conf(tls) } { set nv "\nWARNING: INSECURE CONNECTION" }
146   
147   toplevel .tl
148   wm title .tl {idlebiff: password}
149   message .tl.msg -bg black -fg yellow -width 400 -justify center \
150           -text "${textbad}Enter password for\n$conf(user) at $conf(host)"
151   pack .tl.msg -side top -fill both
152   entry .tl.entry -relief sunken -bg grey -fg black -width 30 -show *
153   pack .tl.entry -side top
154   button .tl.bok -text OK -padx 20 -command { set pass [ .tl.entry get ]; destroy .tl }
155   pack .tl.bok -side right
156   bind .tl.entry <Return> { .tl.bok invoke }
157   button .tl.bc -text Cancel -command { cleanup $con } -padx 20
158   pack .tl.bc -side left
159   focus .tl.entry
160   vwait pass
161   set p $pass
162   unset pass
163   return $p
164 }
165 
166 proc update_img img \
167 {
168   variable ::shared::conf
169   variable ::shared::new_messages
170 
171   .frame.canvas.button configure -image $img
172   if { $conf(tip) } { tooltip::tooltip .frame.canvas $new_messages }
173 }
174 
175 proc read_conf {} \
176 {
177   upvar #0 argv arg argc argn
178   variable ::shared::conf
179 
180   if {[ == $argn 1 ]} { set config $arg } else { set config "$::env(HOME)/.idlebiffrc" }
181   set cf [ open $config ]
182   while {[ >= [ gets $cf lin ] 0 ]} \
183   {
184     if {[ == [ string index [ string trim $lin ] 0 ] # ]} continue
185     set lconf [ split $lin = ]
186     set val [ join [ lassign $lconf key ] = ]
187     set conf([ string trim $key]) [ string trim $val ]
188   }
189 }
190 
191 proc set_params {} \
192 {
193   variable ::shared::rexp_chk
194 
195   check_conf_and_set_default criteria UNSEEN
196   check_conf_and_set_default nodecor 1
197   check_conf_and_set_default tip 0
198   check_conf_and_set_default tls 0
199   check_conf_and_set_default tls_validate_cert 1
200   check_conf_and_set_default initial_noop 0
201   check_conf_and_set_default imap_trace 0
202   set rexp_chk {(?: |\[)capability }
203 }
204 
205 proc set_search_params {} \
206 {
207   variable ::shared::cap
208   variable ::shared::search
209   variable ::shared::rexpsearch
210   variable ::shared::conf
211 
212   if { $cap(esearch) } \
213   {
214     set search "SEARCH RETURN (COUNT) $conf(criteria)"
215     set rexpsearch {^\* esearch \(tag [^)]*\) count (.*)$}
216   } \
217   else \
218   {
219     set search "SEARCH $conf(criteria)"
220     set rexpsearch {^\* search((?: .*|$))}
221   }
222 }
223 
224 proc emit_error args { error $args }
225 
226 proc set_timeout {} \
227 {
228   variable ::shared::conf
229   variable ::shared::tevent
230   variable ::shared::teidf
231 
232   set tevent($teidf) [ after ${conf(timeout)}000 \
233                        {
234                          update_img $::shared::img_chk
235                          cancel_timeout
236                          close $con
237                          init
238                        } \ 
239                      ]
240   incr teidf  
241 }
242 
243 proc cancel_timeout {} \
244 {
245   variable ::shared::tevent
246   variable ::shared::teidi
247 
248   if {[ info exists tevent($teidi) ]} \
249   {
250     after cancel $tevent($teidi)
251     unset tevent($teidi)
252     incr teidi
253   }
254 }
255 
256 proc exec_terse { com args } \
257 {
258   if {[ catch { set res [ eval "$com [ join $args]" ] } ]} \
259   {
260     set terse [ split $::errorInfo "\n" ]
261     puts [ join [ lrange $terse 0 0 ] ]
262     exit 1
263   }
264   return $res
265 }
266 
267 proc recon con \
268 {
269   variable ::shared::ka
270   variable ::shared::idle
271   variable ::shared::img_chk
272 
273   after cancel $ka
274   update_img $img_chk
275   set idle 0
276   catch { close $con }
277   after 3000 init
278 }
279 
280 proc imap_command { con com } \
281 {
282   variable ::shared::conf
283 
284   if { $conf(imap_trace) } \
285   { if {[ regexp {.*LOGIN.*} $com ]} { puts "C: [string range $com 0 10]" } else { puts "C: $com" } }
286 
287   set r [ catch { puts $con $com } ]
288   if {[ eq $com LOGOUT ]} return
289   if { $r } \
290   {
291     recon $con
292     return
293   }
294   set_timeout
295 }
296 
297 proc imap_command_tagged { con com { prefix A } } \
298 {
299   variable ::static::ntag
300   variable ::shared::tag
301 
302   if {[ == $ntag 10000 ]} { set ntag 1 }
303   setappend tag $prefix [ format %04d $ntag ]
304   append tcom $tag { } $com
305   imap_command $con $tcom
306   incr ntag
307 }
308 
309 proc ok_tagged { linea { tag {A\d+} } } \
310 {
311   append rexp {^} $tag { ok.*$}
312   return [ regexp -lineanchor -nocase $rexp $linea ]
313 }
314 
315 proc ok_untagged linea \
316 {
317   return [ regexp -lineanchor -nocase {^\* ok.*$} $linea ]
318 }
319 
320 proc no_tagged linea \
321 {
322   return [ regexp -lineanchor -nocase {^A\d+ no.*$} $linea ]
323 }
324 
325 proc login { con retr } \
326 {
327   variable ::shared::conf
328   variable ::shared::cap
329 
330   if { $cap(logindisabled) } { emit_error logindisabled }
331 
332   if { $retr } { unset conf(pass) }
333   if { ![ info exists conf(pass) ] } { set conf(pass) [ get_password $retr ] }
334 
335   imap_command_tagged $con "LOGIN $conf(user) $conf(pass)"
336 }
337 
338 proc logout con \
339 {
340   variable ::shared::conf
341 
342   fileevent $con readable { parse_logout $con }
343   after ${conf(timeout_logout)}000 \
344   {
345     close $con
346     exit 0
347   }
348   imap_command_tagged $con LOGOUT
349 }
350 
351 proc cleanup con \
352 {
353   variable ::shared::ka
354   variable ::shared::img_chk
355   variable ::shared::idle
356 
357   update_img $img_chk
358   after cancel $ka
359   if { $idle } { exit_idle $con }
360   logout $con
361 }
362 
363 proc force_down {} \
364 {
365   variable ::shared::img_down
366 
367   update_img $img_down
368 }
369 
370 proc enter_idle con \
371 {
372   imap_command_tagged $con IDLE
373 }
374 
375 proc exit_idle con \
376 {
377   variable ::shared::idle
378 
379   set idle 0
380   imap_command $con DONE
381 }
382 
383 proc enter_mailbox con \
384 {
385   variable ::shared::conf
386 
387   imap_command_tagged $con "EXAMINE $conf(mailbox)"
388 }
389 
390 proc exit_mailbox con \
391 {
392   imap_command_tagged $con CLOSE
393 }
394 
395 proc do_search con \
396 {
397   variable ::shared::search
398   variable ::shared::img_chk
399 
400   update_img $img_chk
401   imap_command_tagged $con $search
402 }
403 
404 proc check_cap { linea args } \
405 {
406   variable ::shared::cap
407   variable ::shared::rexp_chk
408 
409   if {[ regexp -nocase -lineanchor $rexp_chk $linea ]} \
410   {
411     if {[ eq $args logindisabled ]} { set cap(logindisabled_chk) 1 } \
412     else { set cap(chk) 1 }
413     foreach capname $args \
414     {
415       if { !$cap($capname) } \
416       {
417         set rexp_cap " ${capname}(?: |]|$)"
418         set cap($capname) [ regexp -nocase -lineanchor $rexp_cap $linea ]
419       }
420     }
421   }
422 }
423 
424 proc idle_cycle { con check } \
425 {
426   variable ::shared::conf
427   variable ::shared::ka
428 
429   after cancel $ka
430   exit_idle $con
431   if { $check } { do_search $con } \
432   else { enter_idle $con }
433   set ka [ after ${conf(keepalive)}000 { idle_cycle $con 0 } ]
434 }
435 
436 proc init_idle con \
437 {
438   variable ::shared::conf
439   variable ::shared::ka
440   variable ::shared::cap
441 
442   if { !$cap(idle) } { emit_error noidle }
443   fileevent $con readable { parse_idle_check $con }
444   enter_mailbox $con
445   set_search_params
446   do_search $con
447   set ka [ after ${conf(keepalive)}000 { idle_cycle $con 0 } ]
448 }
449 
450 proc parse_greeting con \
451 {
452   variable ::shared::cap
453 
454   set linea [ read_line $con ]
455   check_cap $linea logindisabled
456   if {[ ok_untagged $linea ]} \
457   {
458     if { $cap(logindisabled_chk) } \
459     {
460       fileevent $con readable { parse_login $con }
461       login $con 0
462     } \
463     else \
464     {
465       fileevent $con readable { parse_logindisabled $con }
466       imap_command_tagged $con CAPABILITY
467     }
468   }
469 }
470 
471 proc parse_logindisabled con \
472 {
473   variable ::shared::cap
474 
475   set linea [ read_line $con ]
476   check_cap $linea logindisabled
477   if {[ ok_tagged $linea ]} \
478   {
479     if { $cap(logindisabled_chk) } \
480     {
481       fileevent $con readable { parse_login $con }
482       login $con 0
483     }
484   }
485 }
486 
487 proc parse_login con \
488 {
489   variable ::shared::cap
490 
491   set linea [ read_line $con ]
492   check_cap $linea idle esearch
493   if {[ ok_tagged $linea ]} \
494   {
495     if { $cap(chk) } { init_idle $con } \
496     else \
497     {
498       fileevent $con readable { parse_cap $con }
499       imap_command_tagged $con CAPABILITY
500     }
501   } \
502   elseif {[ no_tagged $linea ]} { login $con 1 }
503 }
504 
505 proc parse_cap con \
506 {
507   set linea [ read_line $con ]
508   check_cap $linea idle esearch
509   if {[ ok_tagged $linea ]} { init_idle $con }
510 }
511 
512 proc parse_idle_check con \
513 {
514   variable ::shared::idle
515   variable ::shared::ka
516   variable ::shared::conf
517 
518   if {[ catch { set linea [ read_line $con ] } ]} return
519   set prim [ string range $linea 0 0 ]
520   if {[ eq $prim + ]} { set idle 1 } \
521   elseif { $idle } \
522   {
523     if {[ eq $prim * ]} \
524     {
525       if {[ ok_untagged $linea ]} \
526       {
527         after cancel $ka
528         set ka [ after ${conf(keepalive)}000 { idle_cycle $con 0 } ]
529       } \
530       else { idle_cycle $con 1 } \
531     } \
532   } \
533   else { parse_search $con $linea }
534 }
535 
536 proc parse_search { con linea } \
537 {
538   variable ::shared::conf
539   variable ::shared::img_up
540   variable ::shared::img_down
541   variable ::shared::new_messages
542   variable ::shared::cap
543   variable ::shared::rexpsearch
544   variable ::static::pmsgs
545   variable ::static::search_resp
546 
547   if {[ regexp -lineanchor -nocase $rexpsearch $linea -> res ]} \
548   {
549     if { $cap(esearch) } { set pmsgs $res } else { incr pmsgs [ llength $res ] }
550     set search_resp 1
551   }
552   if {[ and $search_resp [ ok_tagged $linea ] ]} \
553   {
554     enter_idle $con
555     set new_messages $pmsgs
556     set pmsgs 0
557     set search_resp 0
558     if {[ > $new_messages 0 ]} \
559          { set current $img_up } \
560     else { set current $img_down }
561     update_img $current
562   }
563   if {[ no_tagged $linea ]} { emit_error search }
564 }
565 
566 proc parse_logout con \
567 {
568   variable ::shared::conf
569   variable ::shared::tag
570 
571   if {[ catch { gets $con linea } ]} return
572   if { $conf(imap_trace) } { puts "S: $linea" }
573   if {[ ok_tagged $linea $tag ]} \
574   {
575     close $con
576     exit 0
577   }
578 }
579 
580 proc read_line con \
581 {
582   variable ::shared::conf
583 
584   cancel_timeout
585   if {[ catch { set r [ gets $con line ] } ]} \
586   {
587     recon $con
588     return -code error
589   }
590   if {[ regexp -lineanchor -nocase {^\* bye(?: .*|$)} $line ]} \
591   {
592     recon $con
593     return -code error
594   }
595   if {[ and [ < $r 1 ] [ eof $con ] ]} \
596   {
597     recon $con
598     return -code error
599   } \
600   else \
601   {
602     if { $conf(imap_trace) } { puts "S: $line" }
603 
604     return $line
605   }
606 }
607 
608 proc parse_cert_subject sub \
609 {
610   set cst [ split [ string map { , = / = } $sub ] = ]
611   foreach v $cst { lappend cstp [ string trim $v ] }
612   return $cstp
613 }
614 
615 proc tls_cb { type channel depth cert status error } \
616 {
617   variable ::shared::conf
618   variable ::static::ccsu
619   variable ::static::ccsp
620 
621   array set ca $cert
622   if {[ info exists conf(tls_ca_subject) ]} \
623   {
624     if {[ and [ ne $conf(tls_ca_subject) {} ] [ eq $type verify ] [ eq $ca(subject) $ca(issuer) ] ]} \
625     {
626       array set csu [ parse_cert_subject $ca(subject) ]
627       if { !$ccsp } \
628       {
629         array set ccsu [ parse_cert_subject $conf(tls_ca_subject) ]
630         set ccsp 1
631       }
632       foreach i [ array names ccsu ] \
633       {
634         if { ![ info exists csu($i) ] } { emit_error cert }
635         if {[ ne $csu($i) $ccsu($i) ]} { emit_error cert }
636       }
637     }
638   }
639 }
640 
641 proc init_tls {} \
642 {
643   variable ::shared::conf
644   variable ::shared::sock
645 
646   if { $conf(tls) } \
647   {
648     set tlsv [ package require tls ]
649     if {[ >= $tlsv 1.6.4 ]} { set tls1x {-tls1.1 1 -tls1.2 1} } \
650     else { set tls1x {} }
651     if {[ info exists conf(sni) ]} { set sni "-servername $conf(sni)" } \
652     else { set sni {} }
653     set sock "::tls::socket -ssl2 0 -ssl3 0 -tls1 1 $tls1x \
654       -cafile   \"$conf(tls_ca_file)\" \
655       -cadir    \"$conf(tls_ca_dir)\" \
656       -certfile \"$conf(tls_client_cert)\" \
657       -keyfile  \"$conf(tls_client_key)\" \
658       -request  \"$conf(tls_validate_cert)\" \
659       -require  \"$conf(tls_validate_cert)\" \
660       -cipher   \"$conf(tls_ciphers)\" \
661       $sni \
662       -command  tls_cb"
663   } \
664   else { set sock socket }
665 }
666 
667 proc init {} \
668 {
669   upvar #0 con con
670   variable ::shared::conf
671   variable ::shared::sock
672 
673   set con [ exec_terse $sock -async $conf(host) $conf(port) ]
674   fconfigure $con -blocking 0 -buffering line -translation {crlf crlf}
675   fileevent $con readable { parse_greeting $con }
676   if { $conf(initial_noop) } { imap_command_tagged $con NOOP N }
677 }
678 
679 read_conf
680 set_params
681 icon
682 init_tls
683 init
684 
685 vwait forever