initial checkin of site-watcher

extra/site-watcher/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

extra/site-watcher/site-watcher-docs.factor

@@ -0,0 +1,60 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs help.markup help.syntax kernel urls alarms calendar ;
+IN: site-watcher
+
+HELP: run-site-watcher
+{ $description "Starts the site-watcher on the assoc stored in " { $link sites } "." } ;
+
+HELP: running-site-watcher
+{ $var-description "A symbol storing the alarm of a running site-watcher if started with the " { $link run-site-watcher } " word. To prevent multiple site-watchers from running, this variable is checked before allowing another site-watcher to start." } ;
+
+HELP: site-watcher-from
+{ $var-description "The email address from which site-watcher sends emails." } ;
+
+HELP: sites
+{ $var-description "A symbol storing an assoc of URLs, data about a site, and who to notify if a site goes down." } ;
+
+HELP: watch-site
+{ $values
+    { "emails" "a string containing an email address, or an array of such" }
+    { "url" url }
+}
+{ $description "Adds a new site to the watch assoc stored in " { $link sites } ", or adds email addresses to an already watched site." } ;
+
+HELP: watch-sites
+{ $values
+    { "assoc" assoc }
+    { "alarm" alarm }
+}
+{ $description "Runs the site-watcher on the input assoc and returns the alarm that times the site check loop. This alarm may be turned off with " { $link cancel-alarm } ", thus stopping the site-watcher." } ;
+
+HELP: site-watcher-frequency
+{ $var-description "A " { $link duration } " specifying how long to wait between checking sites." } ;
+
+HELP: unwatch-site
+{ $values
+    { "emails" "a string containing an email, or an array of such" }
+    { "url" url }
+}
+{ $description "Removes an email address from being notified when a site's goes down. If this email was the last one watching the site, removes the site as well." } ;
+
+HELP: delete-site
+{ $values
+    { "url" url }
+}
+{ $description "Removes a watched site from the " { $link sites } " assoc." } ;
+
+ARTICLE: "site-watcher" "Site watcher"
+"The " { $vocab-link "site-watcher" } " vocabulary monitors websites and sends email when a site goes down or comes up." $nl
+"To monitor a site:"
+{ $subsection watch-site }
+"To stop email addresses from being notified if a site's status changes:"
+{ $subsection unwatch-site }
+"To stop monitoring a site for all email addresses:"
+{ $subsection delete-site }
+"To run site-watcher using the sites variable:"
+{ $subsection run-site-watcher }
+;
+
+ABOUT: "site-watcher"

extra/site-watcher/site-watcher.factor

@@ -0,0 +1,114 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alarms assocs calendar combinators
+continuations fry http.client io.streams.string kernel init
+namespaces prettyprint smtp arrays sequences math math.parser
+strings sets ;
+IN: site-watcher
+
+SYMBOL: sites
+
+SYMBOL: site-watcher-from
+
+sites [ H{ } clone ] initialize
+
+TUPLE: watching emails url last-up up? send-email? error ;
+
+<PRIVATE
+
+: ?1array ( array/object -- array )
+    dup array? [ 1array ] unless ; inline
+
+: <watching> ( emails url -- watching )
+    watching new
+        swap >>url
+        swap ?1array >>emails
+        now >>last-up
+        t >>up? ;
+
+ERROR: not-watching-site url status ;
+
+: set-site-flags ( watching new-up? -- watching )
+    [ over up?>> = [ t >>send-email? ] unless ] keep >>up? ;
+
+: site-bad ( watching error -- )
+    >>error f set-site-flags drop ;
+
+: site-good ( watching -- )
+    f >>error
+    t set-site-flags
+    now >>last-up drop ;
+
+: check-sites ( assoc -- )
+    [
+        swap '[ _ http-get 2drop site-good ] [ site-bad ] recover
+    ] assoc-each ;
+
+: site-up-email ( email watching -- email )
+    last-up>> now swap time- duration>minutes 60 /mod
+    [ >integer number>string ] bi@
+    [ " hours, " append ] [ " minutes" append ] bi* append
+    "Site was down for (at least): " prepend >>body ;
+
+: ?unparse ( string/object -- string )
+    dup string? [ unparse ] unless ; inline
+
+: site-down-email ( email watching -- email )
+    error>> ?unparse >>body ;
+
+: send-report ( watching -- )
+    [ <email> ] dip
+    {
+        [ emails>> >>to ]
+        [ drop site-watcher-from get "factor.site.watcher@gmail.com" or >>from ]
+        [ dup up?>> [ site-up-email ] [ site-down-email ] if ]
+        [ [ url>> ] [ up?>> "up" "down" ? ] bi " is " glue >>subject ]
+        [ f >>send-email? drop ]
+    } cleave send-email ;
+
+: report-sites ( assoc -- )
+    [ nip send-email?>> ] assoc-filter
+    [ nip send-report ] assoc-each ;
+
+PRIVATE>
+
+SYMBOL: site-watcher-frequency
+site-watcher-frequency [ 5 minutes ] initialize
+
+: watch-sites ( assoc -- alarm )
+    '[
+        _ [ check-sites ] [ report-sites ] bi
+    ] site-watcher-frequency get every ;
+
+: watch-site ( emails url -- )
+    sites get ?at [
+        [ [ ?1array ] dip append prune ] change-emails drop
+    ] [
+        <watching> dup url>> sites get set-at
+    ] if ;
+
+: delete-site ( url -- )
+    sites get delete-at ;
+
+: unwatch-site ( emails url -- )
+    [ ?1array ] dip
+    sites get ?at [
+        [ diff ] change-emails dup emails>> empty? [
+            url>> delete-site
+        ] [
+            drop
+        ] if 
+    ] [
+        nip delete-site
+    ] if ;
+
+SYMBOL: running-site-watcher
+
+: run-site-watcher ( -- )
+    running-site-watcher get-global [
+        sites get-global watch-sites running-site-watcher set-global
+    ] unless ;
+
+[ f running-site-watcher set-global ] "site-watcher" add-init-hook
+
+MAIN: run-site-watcher