extra/mason/email/email.factor

   1 ! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors calendar combinators continuations debugger io
   4 kernel make mason.common mason.config mason.platform math.order
   5 namespaces sequences smtp ;
   6 IN: mason.email
   7
   8 : mason-email ( body content-type subject -- )
   9     '[
  10         <email>
  11             builder-from get >>from
  12             builder-recipients get >>to
  13             _ >>body
  14             _ >>content-type
  15             _ >>subject
  16         send-email
  17     ] [
  18         "E-MAILING FAILED:" print-timestamp
  19         error. flush
  20     ] recover ;
  21
  22 : subject-prefix ( -- string )
  23     "mason on " platform ": " 3append ;
  24
  25 : report-subject ( status -- string )
  26     [
  27         subject-prefix %
  28         current-git-id get 7 cramp head %
  29         " -- " %
  30         {
  31             { status-clean [ "clean" ] }
  32             { status-dirty [ "dirty" ] }
  33             { status-error [ "error" ] }
  34         } case %
  35     ] "" make ;
  36
  37 : email-report ( report status -- )
  38     [ "text/html" ] dip report-subject mason-email ;
  39
  40 ! Some special logic to throttle the amount of fatal errors
  41 ! coming in, if eg git-daemon goes down on factorcode.org and
  42 ! it fails pulling every 5 minutes.
  43
  44 SYMBOL: last-email-time
  45
  46 SYMBOL: next-email-time
  47
  48 : send-email-throttled? ( -- ? )
  49     ! We sent too many errors. See if its time to send a new
  50     ! one again.
  51     now next-email-time get-global after?
  52     [ f next-email-time set-global t ] [ f ] if ;
  53
  54 : throttle-time ( -- dt ) 6 hours ;
  55
  56 : throttle-emails ( -- )
  57     ! Last e-mail was less than 20 minutes ago. Don't send any
  58     ! errors for 4 hours.
  59     throttle-time hence next-email-time set-global
  60     f last-email-time set-global ;
  61
  62 : maximum-frequency ( -- dt ) 30 minutes ;
  63
  64 : send-email-capped? ( -- ? )
  65     ! We're about to send an error after sending another one.
  66     ! See if we should start throttling emails.
  67     last-email-time get-global
  68     maximum-frequency ago
  69     after?
  70     [ throttle-emails f ] [ t ] if ;
  71
  72 : email-fatal? ( -- ? )
  73     {
  74         { [ next-email-time get-global ] [ send-email-throttled? ] }
  75         { [ last-email-time get-global ] [ send-email-capped? ] }
  76         [ now last-email-time set-global t ]
  77     } cond
  78     dup [ now last-email-time set-global ] when ;
  79
  80 : email-fatal ( string subject -- )
  81     [ print nl print flush ]
  82     [
  83         email-fatal? [
  84             now last-email-time set-global
  85             [ "text/plain" subject-prefix ] dip append
  86             mason-email
  87         ] [ 2drop ] if
  88     ] 2bi ;