;;start a server, returns the connection
;;
(define (start-nn-server portnum )
(let ((rep (nn-socket 'rep)))
(handle-exceptions
exn
(let ((emsg ((condition-property-accessor 'exn 'message) exn)))
(print "ERROR: Failed to start server \"" emsg "\"")
(exit 1))
(nn-bind rep (conc "tcp://*:" portnum)))
rep))
;; open connection to server, send message, close connection
;;
(define (open-send-close-nn host-port msg attrib #!key (timeout 3) ) ;; default timeout is 3 seconds
(let ((req (nn-socket 'req))
(uri (conc "tcp://" host-port))
(res #f)
(contacts (alist-ref 'contact attrib))
(mode (alist-ref 'mode attrib)))
(handle-exceptions
exn
(let ((emsg ((condition-property-accessor 'exn 'message) exn)))
;; Send notification
(print "ERROR: Failed to connect / send to " uri " message was \"" emsg "\"" )
(if (equal? mode "production")
(begin
(print " Sending email to contacts : " contacts )
(let ((email-body (mtut:stml->string (s:body
(s:p (conc "We could not send messages to the server on " uri "." "Please check if the listner is running. It is possible that the host is overloaded due to which it may take too long to respond. \n Contact your system adminstrator if server load is high." (s:br)" Thank You ") )))))
(sendmail (string-join (string-split contacts ";" )) (conc "[Listner Error] Filed to connect to listner on " uri) email-body use_html: #t)))
(print " mode : " mode " Not sending any emails" ))
#f)
(nn-connect req uri)
(print "Connected to the server " )
(nn-send req msg)
(print "Request Sent")
(let* ((th1 (make-thread (lambda ()
(let ((resp (nn-recv req)))
(nn-close req)
(set! res (if (equal? resp "ok")
#t
#f))))
"recv thread"))
(th2 (make-thread (lambda ()
(thread-sleep! timeout)
(thread-terminate! th1))
"timer thread")))
(thread-start! th1)
(thread-start! th2)
(thread-join! th1)
res))))
(define (open-send-receive-nn host-port msg attrib #!key (timeout 3) ) ;; default timeout is 3 seconds
(let ((req (nn-socket 'req))
(uri (conc "tcp://" host-port))
(res #f)
(contacts (alist-ref 'contact attrib))
(mode (alist-ref 'mode attrib)))
(handle-exceptions
exn
(let ((emsg ((condition-property-accessor 'exn 'message) exn)))
;; Send notification
(print "ERROR: Failed to connect / send to " uri " message was \"" emsg "\"" )
(if (equal? mode "production")
(begin
(print " Sending email to contacts : " contacts )
(let ((email-body (mtut:stml->string (s:body
(s:p (conc "We could not send messages to the server on " uri "." "Please check if the listner is running. It is possible that the host is overloaded due to which it may take too long to respond. \n Contact your system adminstrator if server load is high." (s:br)" Thank You ") )))))
(sendmail (string-join (string-split contacts ";" )) (conc "[Listner Error] Filed to connect to listner on " uri) email-body use_html: #t)))
(print " mode : " mode " Not sending any emails" ))
#f)
(nn-connect req uri)
(print "Connected to the server " )
(nn-send req msg)
(print "Request Sent")
;; receive code here
;;(print (nn-recv req))
(let* ((th1 (make-thread (lambda ()
(let ((resp (nn-recv req)))
(nn-close req)
(print resp)
(set! res (if (equal? resp "ok")
#t
#f))))
"recv thread"))
(th2 (make-thread (lambda ()
(thread-sleep! timeout)
(thread-terminate! th1))
"timer thread")))
(thread-start! th1)
(thread-start! th2)
(thread-join! th1)
res))))
((tsend)
(if (null? remargs)
(print "ERROR: missing data to send to trigger listeners")
(let* ((msg (car remargs))
(mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(time-out (if (args:get-arg "-time-out")
(string->number (args:get-arg "-time-out"))
5))
(listeners (configf:get-section mtconf "listeners"))
(user-info (user-information (current-user-id)))
(prev-seen (make-hash-table))) ;; catch duplicates
(if user-info
(begin
(for-each
(lambda (listener)
(let ((host-port (car listener))
(attrib (val->alist (cadr listener))))
(if (and (equal? msg "time-to-die") (not (can-user-kill-listner user-info attrib)))
(begin
(debug:print-error 0 *default-log-port* "User " (car user-info) " is not allowed to send message '" msg"'")
(exit 1)))
(print "sending " msg " to " host-port )
(open-send-close-nn host-port msg attrib timeout: time-out )))
listeners))
(begin
(debug:print-error 0 *default-log-port* "Could not Identify executing user. Will not send any message")
(exit 1))))))
((tquery)
(if (null? remargs)
(print "ERROR: missing data to send to trigger listeners")
(let* ((msg (car remargs))
(mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(time-out (if (args:get-arg "-time-out")
(string->number (args:get-arg "-time-out"))
5))
(listeners (configf:get-section mtconf "listeners"))
(user-info (user-information (current-user-id)))
(prev-seen (make-hash-table))) ;; catch duplicates
(if user-info
(begin
(for-each
(lambda (listener)
(let ((host-port (car listener))
(attrib (val->alist (cadr listener))))
(if (and (equal? msg "time-to-die") (not (can-user-kill-listner user-info attrib)))
(begin
(debug:print-error 0 *default-log-port* "User " (car user-info) " is not allowed to send message '" msg"'")
(exit 1)))
(print "sending " msg " to " host-port )
(open-send-receive-nn host-port msg attrib timeout: time-out )))
listeners))
(begin
(debug:print-error 0 *default-log-port* "Could not Identify executing user. Will not send any message")
(exit 1))))))
((tquerylisten)
(if (null? remargs)
(print "ERROR: useage for tlisten is \"mtutil tlisten portnum\"")
(let ((portnum (string->number (car remargs))))
(if (not portnum)
(print "ERROR: the portnumber parameter must be a number, you gave: " (car remargs))
(begin
(if (not (is-port-in-use portnum))
(let* ((rep (start-nn-server portnum))
(mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(contact (configf:lookup mtconf "listener" "owner"))
(script (configf:lookup mtconf "listener" "script")))
(print "Listening on port " portnum " for messages.")
(set-signal-handler! signal/int (lambda (signum)
(set! *time-to-exit* #t)
(debug:print-error 0 *default-log-port* "Received signal " signum " sending email befor exiting !!")
(let ((email-body (mtut:stml->string (s:body
(s:p (conc "Received signal " signum ". Lister has been terminated on host " (get-environment-variable "HOST") ". "))))))
(sendmail contact "Listner has been terminated." email-body use_html: #t))
(exit)))
(set-signal-handler! signal/term (lambda (signum)
(set! *time-to-exit* #t)
(debug:print-error 0 *default-log-port* "Received signal " signum " sending email befor exiting !!")
(let ((email-body (mtut:stml->string (s:body
(s:p (conc "Received signal " signum ". Lister has been terminated on host " (get-environment-variable "HOST") ". "))))))
(sendmail contact "Listner has been terminated." email-body use_html: #t))
(exit)))
;(set-signal-handler! signal/term special-signal-handler)
(let loop ((instr (nn-recv rep)))
;;(nn-send rep "3.9")
(with-input-from-pipe (conc "/usr/bin/uptime | cut -d':' -f4 | awk '{print $1}' | cut -d',' -f1")
(lambda()
(let loop ((inl (read-line)))
(if (not (eof-object? inl))
(begin
;;(print "fdk73: " inl ":")
;;(set! current-list-ciaf (append! current-list-ciaf (list (string-substitute "\\s+$" "" inl))))
(nn-send rep inl)
(loop(read-line)))
))
)
)
;;(print (isys "/usr/bin/uptime" foreach-stdout-thunk: foreach-stdout))
(let ((ctime (date->string (current-date))))
(if (equal? instr "time-to-die")
(begin
(debug:print 0 *default-log-port* ctime " received '" instr "'. Time to sucide." )
(let ((pid (current-process-id)))
(debug:print 0 *default-log-port* "Killing current process (pid=" pid ")")
(system (conc "kill " pid))))
(begin
(debug:print 0 *default-log-port* ctime " received " instr )
;(nn-send rep "ok")
(if (not (equal? instr "ping"))
(begin
(debug:print 0 *default-log-port* ctime " running \"" script " " instr "\"")
;(system (conc script " '" instr "'"))
(process-run script (list instr ))
(debug:print 0 *default-log-port* ctime " done" ))
(begin
(if (not (equal? instr "load"))
(print "Checking load")
)
)
)
)))
(loop (nn-recv rep))))
(print "ERROR: Port " portnum " already in use. Try another port")))))))
((tlisten)
(if (null? remargs)
(print "ERROR: useage for tlisten is \"mtutil tlisten portnum\"")
(let ((portnum (string->number (car remargs))))
(if (not portnum)
(print "ERROR: the portnumber parameter must be a number, you gave: " (car remargs))
(begin
(if (not (is-port-in-use portnum))
(let* ((rep (start-nn-server portnum))
(mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(contact (configf:lookup mtconf "listener" "owner"))
(script (configf:lookup mtconf "listener" "script")))
(print "Listening on port " portnum " for messages.")
(set-signal-handler! signal/int
(lambda (signum)
(set! *time-to-exit* #t)
(debug:print-error 0 *default-log-port* "Received signal " signum
" sending email befor exiting !!")
(let ((email-body (mtut:stml->string
(s:body
(s:p (conc "Received signal " signum
". Lister has been terminated on host "
(get-environment-variable "HOST") ". "))))))
(sendmail contact "Listner has been terminated." email-body use_html: #t))
(exit)))
(set-signal-handler! signal/term (lambda (signum)
(set! *time-to-exit* #t)
(debug:print-error 0 *default-log-port* "Received signal "
signum " sending email befor exiting !!")
(let ((email-body (mtut:stml->string
(s:body
(s:p (conc "Received signal " signum
". Lister has been terminated on host "
(get-environment-variable "HOST") ". "))))))
(sendmail contact "Listner has been terminated." email-body use_html: #t))
(exit)))
;; (set-signal-handler! signal/term special-signal-handler)
(let loop ((instr (nn-recv rep)))
(nn-send rep "ok")
(let ((ctime (date->string (current-date))))
(if (equal? instr "time-to-die")
(begin
(debug:print 0 *default-log-port* ctime " received '" instr "'. Time to sucide." )
(let ((pid (current-process-id)))
(debug:print 0 *default-log-port* "Killing current process (pid=" pid ")")
(system (conc "kill " pid))))
(begin
(debug:print 0 *default-log-port* ctime " received " instr )
;(nn-send rep "ok")
(if (not (equal? instr "ping"))
(begin
(debug:print 0 *default-log-port* ctime " running \"" script " " instr "\"")
(system (conc script " '" instr "' &"))
;(process-run script (list instr ))
(debug:print 0 *default-log-port* ctime " done" ))
(begin
(if (not (equal? instr "load"))
(print "Checking load")
)
)
)
)))
(loop (nn-recv rep))))
(print "ERROR: Port " portnum " already in use. Try another port")))))))
;; from bard
(define (start-nanomsg-server)
(let* ((socket (socket-connect "inproc://my-server")))
(begin
(set-socket-option socket 'linger 1)
(set-socket-option socket 'sndbuf 1024)
(set-socket-option socket 'rcvbuf 1024)
(loop
(let ((msg (receive-message socket)))
(if msg
(handle-message msg)
(exit))))))