extra/site-watcher/site-watcher.factor

   1 ! Copyright (C) 2009 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alarms assocs calendar combinators
   4 continuations fry http.client io.streams.string kernel init
   5 namespaces prettyprint smtp arrays sequences math math.parser
   6 strings sets ;
   7 IN: site-watcher
   8
   9 SYMBOL: sites
  10
  11 SYMBOL: site-watcher-from
  12
  13 sites [ H{ } clone ] initialize
  14
  15 TUPLE: watching emails url last-up up? send-email? error ;
  16
  17 <PRIVATE
  18
  19 : ?1array ( array/object -- array )
  20     dup array? [ 1array ] unless ; inline
  21
  22 : <watching> ( emails url -- watching )
  23     watching new
  24         swap >>url
  25         swap ?1array >>emails
  26         now >>last-up
  27         t >>up? ;
  28
  29 ERROR: not-watching-site url status ;
  30
  31 : set-site-flags ( watching new-up? -- watching )
  32     [ over up?>> = [ t >>send-email? ] unless ] keep >>up? ;
  33
  34 : site-bad ( watching error -- )
  35     >>error f set-site-flags drop ;
  36
  37 : site-good ( watching -- )
  38     f >>error
  39     t set-site-flags
  40     now >>last-up drop ;
  41
  42 : check-sites ( assoc -- )
  43     [
  44         swap '[ _ http-get 2drop site-good ] [ site-bad ] recover
  45     ] assoc-each ;
  46
  47 : site-up-email ( email watching -- email )
  48     last-up>> now swap time- duration>minutes 60 /mod
  49     [ >integer number>string ] bi@
  50     [ " hours, " append ] [ " minutes" append ] bi* append
  51     "Site was down for (at least): " prepend >>body ;
  52
  53 : ?unparse ( string/object -- string )
  54     dup string? [ unparse ] unless ; inline
  55
  56 : site-down-email ( email watching -- email )
  57     error>> ?unparse >>body ;
  58
  59 : send-report ( watching -- )
  60     [ <email> ] dip
  61     {
  62         [ emails>> >>to ]
  63         [ drop site-watcher-from get "factor.site.watcher@gmail.com" or >>from ]
  64         [ dup up?>> [ site-up-email ] [ site-down-email ] if ]
  65         [ [ url>> ] [ up?>> "up" "down" ? ] bi " is " glue >>subject ]
  66         [ f >>send-email? drop ]
  67     } cleave send-email ;
  68
  69 : report-sites ( assoc -- )
  70     [ nip send-email?>> ] assoc-filter
  71     [ nip send-report ] assoc-each ;
  72
  73 PRIVATE>
  74
  75 SYMBOL: site-watcher-frequency
  76 site-watcher-frequency [ 5 minutes ] initialize
  77
  78 : watch-sites ( assoc -- alarm )
  79     '[
  80         _ [ check-sites ] [ report-sites ] bi
  81     ] site-watcher-frequency get every ;
  82
  83 : watch-site ( emails url -- )
  84     sites get ?at [
  85         [ [ ?1array ] dip append prune ] change-emails drop
  86     ] [
  87         <watching> dup url>> sites get set-at
  88     ] if ;
  89
  90 : delete-site ( url -- )
  91     sites get delete-at ;
  92
  93 : unwatch-site ( emails url -- )
  94     [ ?1array ] dip
  95     sites get ?at [
  96         [ diff ] change-emails dup emails>> empty? [
  97             url>> delete-site
  98         ] [
  99             drop
 100         ] if
 101     ] [
 102         nip delete-site
 103     ] if ;
 104
 105 SYMBOL: running-site-watcher
 106
 107 : run-site-watcher ( -- )
 108     running-site-watcher get-global [
 109         sites get-global watch-sites running-site-watcher set-global
 110     ] unless ;
 111
 112 [ f running-site-watcher set-global ] "site-watcher" add-init-hook
 113
 114 MAIN: run-site-watcher