Removing web-server monitor. Not our job and poorly written. Renaming launchers
svn: r6416
This commit is contained in:
Jay McCarthy
parent
8b1cb2bda9
commit
3b675372d9
|
|
@ -5,11 +5,11 @@
|
|||
(list))
|
||||
|
||||
(define mzscheme-launcher-libraries
|
||||
(list "private/text-launch.ss" "private/monitor-launch.ss" "private/setup-launch.ss" ))
|
||||
(list "private/launch-text.ss" "private/setup-launch.ss" ))
|
||||
(define mzscheme-launcher-names
|
||||
(list "PLT Web Server Text" "PLT Web Server Monitor" "PLT Web Server Setup"))
|
||||
(list "PLT Web Server Text" "PLT Web Server Setup"))
|
||||
|
||||
(define mred-launcher-libraries
|
||||
(list "private/gui-launch.ss"))
|
||||
(list "private/launch-gui.ss"))
|
||||
(define mred-launcher-names
|
||||
(list "PLT Web Server")))
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
(module gui-launch mzscheme
|
||||
(module launch-gui mzscheme
|
||||
(require (lib "class.ss")
|
||||
(lib "mred.ss" "mred"))
|
||||
(require "launch.ss")
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
(module text-launch mzscheme
|
||||
(module launch-text mzscheme
|
||||
(require "launch.ss"
|
||||
(only "../web-server.ss" do-not-return))
|
||||
(serve)
|
||||
|
|
@ -1,19 +0,0 @@
|
|||
(module monitor-emailer mzscheme
|
||||
(require (lib "sendmail.ss" "net")
|
||||
(lib "contract.ss"))
|
||||
|
||||
(provide/contract [send-email-alert (string? ; email address
|
||||
string? ; server-name
|
||||
number? ; server-port
|
||||
string? ; message
|
||||
. -> .
|
||||
void?)])
|
||||
|
||||
; send-email-alert : send an email to the specified address informing them of the failure.
|
||||
(define (send-email-alert alert-address server-name server-port message)
|
||||
(send-mail-message alert-address
|
||||
(format "The server ~a:~a is not responding!" server-name server-port)
|
||||
(list alert-address)
|
||||
null
|
||||
null
|
||||
(list message '("" "Fix it ASAP!!!")))))
|
||||
|
|
@ -1,31 +0,0 @@
|
|||
; The main program of the "web-server-monitor" launcher.
|
||||
(module monitor-launch mzscheme
|
||||
(require "monitor-server.ss"
|
||||
"util.ss"
|
||||
(lib "cmdline.ss"))
|
||||
|
||||
; handle-numeric-flag : sym -> str str -> (cons sym num)
|
||||
(define (handle-numeric-flag name)
|
||||
(lambda (dc-flag arg)
|
||||
(cons name (string->number arg))))
|
||||
|
||||
(parse-command-line
|
||||
"web-server-monitor"
|
||||
(current-command-line-arguments)
|
||||
`((once-each
|
||||
[("-p" "--port")
|
||||
,(handle-numeric-flag 'port)
|
||||
("Connects to the network port <port>." "port")]
|
||||
[("-f" "--frequency")
|
||||
,(handle-numeric-flag 'frequency)
|
||||
("Polls every <frequency> seconds." "frequency")]
|
||||
[("-t" "--timeout")
|
||||
,(handle-numeric-flag 'timeout)
|
||||
("Assumes failure after <timeout> seconds." "timeout")]))
|
||||
(lambda (flags email-address host-name)
|
||||
(monitor email-address
|
||||
host-name
|
||||
(extract-flag 'port flags default-server-port)
|
||||
(extract-flag 'frequency flags default-poll-frequency-seconds)
|
||||
(extract-flag 'timeout flags default-server-response-timeout-seconds)))
|
||||
'("email-address" "host-name")))
|
||||
|
|
@ -1,85 +0,0 @@
|
|||
(module monitor-poke-web-server mzscheme
|
||||
(require (lib "contract.ss")
|
||||
(lib "match.ss"))
|
||||
|
||||
;; this file contains functions to check whether a given host is responding to HTTP requests,
|
||||
;; specifically to a "HEAD ~a HTTP/1.0" request, where ~a is supplied by the caller.
|
||||
|
||||
;; the original code was Paul Graunke's, refactored & encontracted by John Clements
|
||||
|
||||
|
||||
(define (poke-result? result)
|
||||
(match result
|
||||
[`(fail ,(? string? server-name) ,(? number? server-port) ,(? string? msg)) #t]
|
||||
[`(timeout ,(? string? server-name) ,(? number? server-port) ,(? number? timeout-seconds)) #t]
|
||||
[`(exn ,(? string? server-name) ,(? number? server-port) ,(? exn? exn)) #t]
|
||||
[`(ok) #t]
|
||||
[else #f]))
|
||||
|
||||
(provide/contract [poke-web-server (channel? ; result-channel
|
||||
string? ; server-name
|
||||
number? ; server-port
|
||||
number? ; timeout-seconds
|
||||
. -> .
|
||||
void?)]
|
||||
[poke-web-server/path (string? ; path
|
||||
channel? ; result-channel
|
||||
string? ; server-name
|
||||
number? ; server-port
|
||||
number? ; timeout-seconds
|
||||
. -> .
|
||||
void?)]
|
||||
[result->message (poke-result? . -> . string?)])
|
||||
|
||||
(define OK-REGEXP (regexp "^HTTP/[0-9]*.[0-9]* 200"))
|
||||
|
||||
|
||||
; result->message : given a poke-result?, produce a reasonable error message.
|
||||
(define (result->message result)
|
||||
(match result
|
||||
[`(fail ,server-name ,server-port ,line)
|
||||
(string-append
|
||||
(format "The web server ~a:~a did not respond\n" server-name server-port)
|
||||
"to a head request for its home page with an 'okay' result.\n"
|
||||
(format "Received: ~a\n" line))]
|
||||
[`(timeout ,server-name ,server-port ,timeout-seconds)
|
||||
(string-append
|
||||
(format "Attempting to send a head request to ~a:~a\n" server-name server-port)
|
||||
(format "timed out after ~a seconds.\n" timeout-seconds))]
|
||||
[`(exn ,server-name ,server-port ,exn)
|
||||
(string-append
|
||||
(format "Attempting to send a head request to ~a:~a\n" server-name server-port)
|
||||
"resulted in the following exception:\n"
|
||||
"\n"
|
||||
(format "~a\n" (if (exn? exn)
|
||||
(exn-message exn)
|
||||
exn)))]
|
||||
[`(ok) "no error"]))
|
||||
|
||||
(define (poke-web-server result-channel server-name server-port timeout-seconds)
|
||||
(poke-web-server/path "/" result-channel server-name server-port timeout-seconds))
|
||||
|
||||
(define (poke-web-server/path path result-channel server-name server-port timeout-seconds)
|
||||
(let* ([cust (make-custodian)]
|
||||
[blow-up-handler (lambda (exn)
|
||||
(channel-put result-channel `(exn ,server-name ,server-port ,exn))
|
||||
(custodian-shutdown-all cust))])
|
||||
(parameterize ([current-custodian cust])
|
||||
(thread (lambda ()
|
||||
(with-handlers ([void blow-up-handler])
|
||||
(sleep timeout-seconds))
|
||||
(channel-put result-channel `(timeout ,server-name ,server-port ,timeout-seconds))
|
||||
(custodian-shutdown-all cust)))
|
||||
(thread
|
||||
(lambda ()
|
||||
(with-handlers ([void blow-up-handler])
|
||||
(let-values ([(in out) (tcp-connect server-name server-port)])
|
||||
(fprintf out "HEAD ~a HTTP/1.0\r\n" path)
|
||||
(fprintf out "Host: ~a\r\n\r\n" server-name) ; what the jiminy cricket does this line do;?
|
||||
(flush-output out) ;; now required for all TCP ports
|
||||
(let ([line (read-line in)])
|
||||
(if (regexp-match OK-REGEXP line)
|
||||
(channel-put result-channel '(ok))
|
||||
(channel-put result-channel `(fail ,server-name ,server-port ,line)))
|
||||
(custodian-shutdown-all cust))))))
|
||||
(void)))))
|
||||
|
|
@ -1,38 +0,0 @@
|
|||
(module monitor-server mzscheme
|
||||
(require (lib "etc.ss")
|
||||
(lib "contract.ss")
|
||||
(lib "match.ss"))
|
||||
(require "monitor-poke-web-server.ss"
|
||||
"monitor-emailer.ss")
|
||||
|
||||
(define default-server-port 80)
|
||||
(define default-poll-frequency-seconds 3600)
|
||||
(define default-server-response-timeout-seconds 75)
|
||||
|
||||
; monitor : str str [nat] [num] [num] -> doesn't
|
||||
(define monitor
|
||||
(opt-lambda (email-address
|
||||
server-name
|
||||
[server-port default-server-port]
|
||||
[poll-frequency-seconds default-poll-frequency-seconds]
|
||||
[server-response-timeout-seconds default-server-response-timeout-seconds])
|
||||
|
||||
(define result-channel (make-channel))
|
||||
|
||||
(define (send-email msg)
|
||||
(send-email-alert email-address server-name server-port msg))
|
||||
|
||||
(let check-server ()
|
||||
(poke-web-server result-channel server-name server-port server-response-timeout-seconds)
|
||||
(let ([result (channel-get result-channel)])
|
||||
(match result
|
||||
[`(ok) (void)]
|
||||
[else (send-email (result->message result))])
|
||||
(sleep poll-frequency-seconds)
|
||||
(check-server)))))
|
||||
|
||||
(provide/contract
|
||||
[monitor ((string? string?) (number? number? number?) . opt-> . void)]
|
||||
[default-server-port number?]
|
||||
[default-poll-frequency-seconds number?]
|
||||
[default-server-response-timeout-seconds number?]))
|
||||
Loading…
Reference in New Issue
Block a user