#! /w/web/ns-home/cgi-bin/oleg/gsi -f
;****************************************************************************
;		A Web equivalent of UNIX "tail -f" command
;		
; This CGI code is activated by an HTTP server when serving a URL like
;	/cgi-bin/tail-f?period=600&file=/w/web/ns-home/httpd-80/logs/access
;
; This code gets all necessary parameters via env variables, which are
; supposed to be set by a HTTP server:
;
; HTTP_USER_AGENT=MacWeb/1.00ALPHA3  libwww/2.17
; HTTP_REFERER=file:///Devel/Code/Web Map/tail-f
; PATH=/usr/sbin:/usr/bin
; QUERY_STRING=period=600&file=/w/web/ns-home/httpd-80/logs/access
; REMOTE_ADDR=204.58.152.59
; REMOTE_HOST=hugh.cisi.com
; REQUEST_METHOD=GET
; SCRIPT_NAME=/cgi-bin/tail-f
; SERVER_NAME=nites-2
; SERVER_PORT=80
; SERVER_PROTOCOL=HTTP/1.0
; SERVER_SOFTWARE=NCSA/1.3
;
; Of most interest to us is QUERY_STRING, which contains parameters from
; the URL, in the name=value format separated by ampersands;
; spaces are represented as %20
; The following parameters are expected:
;	file=/w/web/ns-home/httpd-80/logs/access
;	period=600
;	nlines=10
;	send=form or send=watch or send=watching
;
; This code watches the given 'file', sending its last 'nlines' lines to
; the client. Note that this script doesn't quit after the first peek into
; the file, but rather keeps watching the file, checking up on it every
; 'period' seconds.
; The watching stops when a user agent (a browser, that is) closes
; the connection: say, the user has pressed 'stop' button in the browser. Of
; course watching terminates when the file disappears. All in all, this is
; similar to a familiar UNIX "tail -f" command, it merely works across the
; net.
;
; Well, actually we're trying to be considerate, and not to tie up
; computer/connection resources watching for updates that may never happen.
; So, if this code detects that the file being watched hasn't been
; updated for 10 consecutive watch periods, the code quits. The user can
; resume the watch just by resubmitting the form (clicking on the 'watch'
; button).
;
; While looking for the last lines of the 'file', we deliberately don't
; employ direct positioning of the file. For one thing, fseek() etc. functions
; are not standard in Scheme. For another, treating a file as a purely
; sequential stream enables us to handle 'file's which are not
; regular files per se: named (FIFO) pipes, raw devices, serial ports,
; etc.
;
; The 'period' and 'nlines' parameters of the script mentioned above
; aren't mandatory: reasonable defaults exist.
; No matter if the script found all necessary parameters (and found them
; sane) or not, it always outputs a form listing the current parameters,
; as specified (or taken from defaults). If the parameters make sense, the
; script proceeds to watch the file. Otherwise, the user is told off:
; the user is expected to change some fields of the form and resubmit it.
; Thus, the easiest way to call this script is to "Open URL" /cgi-bin/tail-f
; and then follow directions on the form.
;
; The script runs as a some kind of a Finite State Machine (FSM), whose state
; is determined by the parameter 'send'
;	Initial state (#0): 'send' parameter is absent
;		The script only outputs the framework (frames)
;		Its first frame (or the body of <NOFRAMES>)
;		will call this script again with send=form
;	Making a body: send=form
;		makes a form with the current tail-f parameters and
;		sends it to the client
;		form's ACTION is the present script with send=watch
;	Initiating watching the file: send=watch
;		Locating the file, and and letting the user know
;		that we starting the watch
;	Really watching the file: send=watching
;
; The third, initiating step seems to be necessary with all the browsers
; but Netscape 3.0 on a Mac, to redirect the _pushed_ output (which is
; about to follow) into the right frame. Only text/html content seems to
; go where the TARGET of an <A> or <ACTION> tag tells to; other content seems
; to go to the current frame (again, only Mac's Netscape does it right
; the first time)
;
; To keep the browser's attention (to listen to this script output)
; we use a feature called "server push", described in
;	http://home.netscape.com/assist/net_sites/pushpull.html
; Here's a scoop:
;
; <BLOCKQUOTE>
; 	Server push is the other dynamic document mechanism, complementing
; client pull. In contrast to the latter, server push takes advantage of
; a connection that's held open over multiple responses, so the server can
; send down more data any time it wants. The obvious major advantage is that
; the server has total control over when and how often new data is sent down.
; Also, this method can be more efficient, since new HTTP connections don't
; have to be opened all the time. The downside is that the open connection
; consumes a resource on the server side while it's open (only when the server
; knows it wants this to happen, though).
;	....
; For server push we use a variant of "multipart/mixed" called
; "multipart/x-mixed-replace". The "x-" indicates this type is experimental.
; The "replace" indicates that each new data block will cause the previous
; data block to be replaced -- that is, new data will be displayed instead of
; (not in addition to) old data. 
; 
; So here's an example of "multipart/x-mixed-replace" in action: 
;
;Content-type: multipart/x-mixed-replace;boundary=ThisRandomString
;
;--ThisRandomString
;Content-type: text/plain
;
;Data for the first object.
;
;--ThisRandomString
;Content-type: text/plain
;
;Data for the second and last object.
;
;--ThisRandomString--
;
; ....
; Following in the tradition of the standard "multipart/mixed",
; "multipart/x-mixed-replace" messages are composed using a unique
; boundaryline that separates each data object. Each data object has its own
; headers, allowing for an object-specific content type and other
; information to be specified. 
;
; The specific behavior of "multipart/x-mixed-replace" is that each new
; data object replaces the previous data object. The browser gets rid of the
; first data object and instead displays the second data object. 
;
; A "multipart/x-mixed-replace" message doesn't have to end! That is,
; the server can just keep the connection open forever and send down as many
; new data objects as it wants. The process will then terminate if the user
; is no longer displaying that data stream in a browser window or if the
; browser severs the connection (e.g. the user presses the "Stop" button).
; We expect this will be the typical way people will use server push. 
;
; .....
; The previous document will be cleared and the browser will begin displaying
; the next document when the "Content-type" header is found, or at the end of
; the headers otherwise, for a new data block. That is, the current data
; block (document) is considered finished when the next message boundary
; is found. 
;
; Together, the above two items mean that the server should push down the
; pipe: a set of headers (most likely including "Content-type"), the data
; itself, and a separator (message boundary). When the browser sees the
; separator, it knows to sit still and wait indefinitely for the next data
; block to arrive. Note that the boundary is sent to the browser before the
; sleep statement (that is, immediately after the chunk after, not before
; the new chunk is about to be sent). This ensures that the browser will
; flush its buffers and display all the data that's been received up to that
; point to the user. 
;
;#!/bin/sh
;echo "HTTP/1.0 200"
;echo "Content-type: multipart/x-mixed-replace;boundary=---ThisRandomString---"
;echo ""
;echo "---ThisRandomString---"
;while true
;do
;echo "Content-type: text/html"
;echo ""
;echo "<h2>Processes on this machine updated every 5 seconds</h2>"
;echo "time: "
;date
;echo "<p>"
;echo "<plaintext>"
;ps -el
;echo "---ThisRandomString---"
;sleep 5
;done
;
; Special note to NCSA HTTPD users: You must not use any spaces in your
; content type, this includes the boundary argument. NCSA HTTPD will only
; accept a single string with no white space as a content type. If you put
; any spaces in the line (besides the one right after the colon) any text
; after the white space will be truncated.
;
; As an example, the following will work: 
; 	Content-type: multipart/x-mixed-replace;boundary=ThisRandomString
;
; The following will not work: 
;	Content-type: multipart/x-mixed-replace; boundary=ThisRandomString
;
; </BLOCKQUOTE>
;
; Note, the server push (as opposite to the client pull) appears to be more
; in line with HTTP 1.1 spirit
;   http://www.w3.org/pub/WWW/Protocols/HTTP/1.1/draft-ietf-http-v11-spec-07.txt
; which always assumes that connection between a client and a server stays
; open until both parties agree that they have nothing more to say to each
; other.
;
; This script's functioning has been tested with Netscape 3.0 on a Mac and
; UNIX (HP-UX 10.00, Solaris 2.3), Netscape 2.01 on Win95
; and (with limited functionality) IE 3.0 on Win95
;
; $Id: tail-f.scm,v 2.0 1997/03/21 19:07:20 oleg Exp oleg $
;

(declare 
 (block)
 (standard-bindings)
 (fixnum)
)
(##include "myenv.scm") ; include target dependent stuff

	; Tell the client off (because of some error condition)
(define (CGI:bail-out reason . args)
  (cout "Content-type: text/html" nl nl		; TWO nl are very important
    "<html><head><title>Error watching the file</title></head><body>" nl
    "<h1>Problem watching the file</h1>" nl
    "<b>" reason (lambda () (for-each display args)) "</b>" nl
    "</body></html>")
    (exit)
)

(set! error		; redefine the error primitive
  (lambda (msg . args)
    (apply CGI:bail-out
      (cons "caught error: " (cons msg args)))))

	; Parse the URL parameters string
	; That is, convert a string like
	; "parm1=val1&parm2=val2+val%253+val4&%7Eparm3=&parm4"
	; into an assoc list
	; (("parm4") ("~parm3" "")
	;  ("parm2" "val2" "val%3" "val4")
	;  ("parm1" "val1"))
	; Parsing is done by a finite state machine, that takes into
	; account the current state (looking for a parm, looking for a value,
	; looking for a continuation of parm/value after %xx quoted-char),
	; action-prefix ('=', '+', '&' or '/') and the token that follows
	; the action prefix (that is, a set of characters through the next
	; action-prefix or the end-of-string). At the very beginning, the
	; action-prefix is assumed '&'. Note, we assume '/' separator to
	; act exactly like '&' (so we can use the present function to
	; parse both SCRIPT_PATH and QUERY_STRINGs)
	; test
	; (CGI:url-unquote "aaa")
	; (CGI:url-unquote "aaa=")
	; (CGI:url-unquote "aaa=&bbb=b1&ccc=c1+c2&ddd")
	; (CGI:url-unquote "aaa=/bbb=b1/ccc=c1+c2/ddd")
	; (CGI:url-unquote "%7eaaa=/%25b%25bb=b%201/c%20c%7E=c1+c2/ddd%21")
	; Note, that if the string mentions some parameter twice, the
	; _last_ mentioning takes precedence!
(define (CGI:url-unquote parm-string)
  (let ((result '())
        (read-primitive-token
          (lambda ()
            (if (eof-object? (peek-char)) ""
              (next-token '() '(#\= #\+ #\& #\% *eof*) "URL-unquoting")))))
            
    (with-input-from-string parm-string
      (lambda ()
        (do ((action-prefix #\& (read-char)) (status 'init)
             (vals '()) (keyword #f))
           ((eq? status 'stop) result)
           
           (let
             ((token (read-primitive-token)))

             	; If #\% left on stream, read it and the following
             	; two characters (hex digits), unquote the char and
             	; append it to the rest of the token
             (do () ((not (eq? (peek-char) #\%)))
               (read-char)		; read the percent char
               (let ((quoted-char-str (make-string 2)))
                 (string-set! quoted-char-str 0 (read-char))
                 (string-set! quoted-char-str 1 (read-char))
                 (let ((quoted-char (string->number quoted-char-str 16)))
                   (set! token
                     (string-append token 
                       (if quoted-char (string (integer->char quoted-char))
                         "*INVALID-%-SEQ*")
                       (read-primitive-token))))))
             
             (if (eof-object? action-prefix)
               (set! action-prefix '*eof*))
             (set! status
               (case action-prefix 
                 ((#\& *eof* #\/)		; new parmset to follow
                   (case status
                     ((init) #t)
                     ((have-read-keyword)	; parm without any values
                       (set! result (cons (list keyword) result)))
                     ((have-read-value)
                       (set! result (cons (cons keyword (reverse vals)) result)))
                     (else (error "unexpected status " status)))
                   (set! keyword token)
                   (if (eq? action-prefix '*eof*) 'stop 'have-read-keyword))
                 ((#\=)
                   (case status
                     ((have-read-keyword) (set! vals (list token))
                       'have-read-value)
                     ((have-read-value)
                       (error "= unexpected after the first value"))
                     (else (error "unexpected status " status))))
                 ((#\+)
                   (case status
                     ((have-read-keyword)
                       (error "+ unexpected after a keyword"))
                     ((have-read-value)
                       (set! vals (cons token vals)) 'have-read-value)
                     (else (error "unexpected status " status))))
                 (else (error "unexpected action-prefix " action-prefix))))))))))


	; A circular buffer object, which lets one put characters to,
	; and read characters from.
	; The current position in the buffer is specified by a
	; (wrappable-around) index write-index. It always points to a position
	; in the buffer the next character would be written to. When the
	; buffer hasn't been filled yet, the filled part extends from the
	; beginning of the buffer to (but not including) the write-index, with
	; (-- write-index) being the index of the last character put.
	; When the buffer has been filled (that is, write-index has wrapped
	; around once) then
	; 	(mod (-- write-index) size)
	; points to the mostly recent added character, 
	; 	(mod (- write-index 2) size)
	; points to a character out before that, etc; the write-index itself
	; points to the most earliest added character which is still in buffer.
	; When we read from the buffer, the current read position is maintained
	; by a circular index read-index. When (= read-index write-index)
	; there is nothing to read

(define (make-circular-buffer size)
  (let ((buffer (make-string size))
        (total-char-put 0)
        (read-index 0)
        (write-index 0)
        (read-backward #f)
       )

		; Read a character from the current position, and
		; advance the position forward
		; Return #f if there is nothing to read
       (define (read-fwd)
         (cond
           ((= read-index write-index) #f)
           (else
             (let ((c (string-ref buffer read-index)))
               (++! read-index)
               (if (>= read-index size)
                 (set! read-index 0))
               c))))
      
		; Back up the current position by one character
		; and return the current character
		; Return #f if there is nothing to read
		
		; This procedure works when the buffer hasn't been filled
		; completely, that is, the filled part of the buffer is
		; [0,write-index)
       (define (read-backward-when-partly-filled)
         (cond
           ((zero? read-index) #f)
           (else
             (--! read-index)
             (string-ref buffer read-index))))
             
       		; The following procedure applies when the buffer is filled
       		; completely. That is, the filled part is
       		; [write-index+1,size) U [0,write-index)
       (define (read-backward-when-fully-filled)
         (let ((old-read-index read-index))
           (set! read-index
             (if (zero? read-index) (-- size) (-- read-index)))
           (cond
             ((= read-index write-index) (set! read-index old-read-index) #f)
             (else
               (string-ref buffer read-index)))))
             
       
     	; Fill the buffer from the standard input port while it has something
     	; to read. Return the number of characters read from the standard
     	; input
     (define (fill!)
     
       (define-macro (read-char-noblock)
         `(and (char-ready?) (read-char)))
       
       			; The following (admittedly, kludge) seems to be the
       			; only way to get Gambit to note that the input stream
       			; may have more characters to read now (after the
       			; original EOF)
       			; Thus, the second call to (read-char) clears the
       			; EOF condition, and peeks into the input stream anew
        (let ((c (read-char-noblock)))
         (if (eof-object? c) (set! c (read-char-noblock)))

         (do ((no-char-read 0 (++ no-char-read))
            (c c (read-char-noblock)))
           ((not (char? c)) no-char-read)
           (string-set! buffer write-index c)
           (++! total-char-put)
           (++! write-index)
           (when (>= write-index size)
             (set! write-index 0)
             (set! read-backward read-backward-when-fully-filled))
           )))
       
       (set! read-backward read-backward-when-partly-filled)
       
       		; message dispatcher
       (lambda (selector)
         (case selector
           ((fill!) (fill!))
           ((read-anew!) (set! read-index write-index))
           ((read-char-fwd) (read-fwd))
           ((read-char-bwd) (read-backward))
           ((total-char-put) total-char-put)
           (else
             (error "make-circular-buffer doesn't understand message " selector))
           ))
))

; Body of the CGI code
(let*
  ((query-string (OS:getenv "QUERY_STRING"))
   (query-parms (append (CGI:url-unquote (or query-string ""))
      		; default values for the optional parameters
      '(("period" "5") ("nlines" "10"))))
  
   (self-url (string-append "http:"
       (or
         (OS:getenv "SCRIPT_NAME")
         (CGI:bail-out "SCRIPT_NAME env parameter expected"))))
   
   (watch-period
     (or 
       (string->number (cadr (assoc "period" query-parms)))
        (CGI:bail-out "period must be a valid number (of seconds)")))

   (nlines
     (or 
       (string->number (cadr (assoc "nlines" query-parms)))
        (CGI:bail-out "nlines must be a valid number (of lines)")))

   (file-to-watch (cadr (or (assoc "file" query-parms) '(#f #f))))
  )

		; Build the framework
(define (TF:send-framework)
		; self-url-full is the full URL this script was called with
		; (including the query-string), suitable for adding send=xxx
		; to the end of the (query-string)
  (let ((self-url-full
        (string-append self-url "?" (or query-string "")
          (if query-string "&" ""))))
      (cout "Content-type: text/html" nl nl
        "<HTML><HEAD><TITLE>watching for the file</TITLE></HEAD>"
        "<FRAMESET ROWS=\"40%,*\">"
        "<FRAME NAME=\"tf-form\" noresize scrolling=yes SRC=\""
        self-url-full "send=form\">"
        "<FRAME NAME=\"tf-watch\" noresize scrolling=yes SRC=\""
        self-url-full "send=watch\">"
        "<NOFRAMES>"
        "<META HTTP-EQUIV=\"Refresh\" CONTENT=\"0; URL="
        self-url-full "send=form\">"
        "<P>Your browser doesn't seem to support frames. Please "
        "<A HREF=\"" self-url-full "send=form\">follow this link</A>"
        "</NOFRAMES></FRAMESET></HTML>"))
    )


		; Make the form with the current parameters
(define (TF:send-form)
  (cout "Content-type: text/html" nl nl
    "<HTML><HEAD><TITLE>watching for the file</TITLE></HEAD><BODY>"
    "<FORM METHOD=GET TARGET=\"tf-watch\" ACTION=\"" self-url "\">" nl
    "<P>file to watch <INPUT NAME=file TYPE=TEXT SIZE=40 MAXLENGTH=255 VALUE=\""
    (or file-to-watch "") "\">" nl
    "<P>period <INPUT NAME=period TYPE=INT SIZE=4 MAXLENGTH=4 VALUE=\""
    watch-period "\"> seconds"
    "<P>number of lines <INPUT NAME=nlines TYPE=INT SIZE=4 MAXLENGTH=4 VALUE=\""
    nlines "\">" nl
    "<P><INPUT NAME=send TYPE=SUBMIT VALUE=watch></FORM>" nl
    "<P>The watch would be terminated when no updates to the file detected "
    "within 10 consecutive watch periods: you'll see the connection closed"
    "<BR>click on the <CODE>watch</CODE> button above to resume the watch"
    "</BODY></HTML>")
)

		; Prepare to watch the file...
(define (TF:prepare-watch)
  (if (or (not file-to-watch) (string=? file-to-watch ""))
    (CGI:bail-out "no file name specified"))
  (if (not (OS:file-exists? file-to-watch))
    (CGI:bail-out "The file " file-to-watch " does not exist<BR>"
      "or is not permitted to read"))
  (let ((self-url-full
        (string-append self-url "?" (or query-string "")
          (if query-string "&" ""))))
    (cout "Content-type: text/html" nl nl
      "<HTML><HEAD><META HTTP-EQUIV=\"Refresh\" CONTENT=\"0; URL="
        self-url-full "send=watching\">"
        "</HEAD><BODY><P>Starting watch of " file-to-watch 
       "<P>After the file is completely scanned, this display would "
       "<I>automatically</I> change "
       "and you will see the last " nlines " lines of the file<P><BR>" nl
       "If the change does not seem to be coming for a long time, "
       "your browser may not support "
       "a &lt;META&gt; tag. In this case, please "
        "<A HREF=\"" self-url-full "send=watching\">follow this link</A>"
        "</BODY></HTML>" flush-output)))

		; Actual watching of the file
(define (TF:do-watch)
    
  		; The procedure that keeps watching the file, and returns
  		; after the file hasn't been changed after 'max-nochanges'
  		; consecutive watch intervals
  (define (keep-watch)
    (let ((string-separator
           (string-append "---tail-f-" (number->string (OS:time)) "---"))
          (buffer (make-circular-buffer (* (max nlines 1000) 40)))
          (max-nochanges 10)
          (no-changes-count 0))
            
        (define (make-header no-chars-read)
          (cout "Content-type: text/html" nl nl
            "<HTML><BODY><H3>Total characters read " (buffer 'total-char-put)
            ", or " no-chars-read " since the last time</h3>" nl))
                
                ; Set the current reading position nlines backwards
        (define (set-nlines-backwards! nlines)
          (buffer 'read-anew!)
          (let loop ((nl-char-to-read (++ nlines)))
            (if (zero? nl-char-to-read)
              (buffer 'read-char-fwd) ; skip \n that was just read
              (case (buffer 'read-char-bwd)
                ((#f) #f)		; reached the beginning of the buffer
                ((#\newline)
                  (loop (-- nl-char-to-read)))
                (else
                  (loop nl-char-to-read))))))
                  
         
        	; Write the header of the whole multi-part message...
        (cout "Content-type: multipart/x-mixed-replace;boundary="
               string-separator nl nl string-separator nl flush-output)
               
        (do ((first-time #t #f)
             (char-read (buffer 'fill!) (buffer 'fill!)))
            ((and (zero? char-read) (> no-changes-count max-nochanges)))
            (cond 
              ((or (positive? char-read) first-time)
                (set! no-changes-count 0)
                (make-header char-read)
                (when (positive? char-read)
                  (set-nlines-backwards! nlines)
                  (display "<PRE>")
                  (do ((c (buffer 'read-char-fwd) (buffer 'read-char-fwd)))
                      ((not c) (display "</PRE>"))
                      (write-char c))
                )
                (cout nl string-separator nl flush-output))
              (else (++! no-changes-count)))
             (OS:sleep watch-period)
                ;(exit)
             )))
       
  (if (or (not file-to-watch) (string=? file-to-watch ""))
    (CGI:bail-out "no file name specified"))

  (##catch-all
    (lambda (sig . args)
      (apply CGI:bail-out
        (cons "problem reading file " (cons sig args))))
    (lambda ()
      (with-input-from-file file-to-watch keep-watch)))
  )

  ; decide on the current state of the FSM and do the appropriate action
  (let
    ((state (cadr (assoc-def "send" query-parms '(#f #f)))))
    (cond
      ((not state) (TF:send-framework))
      ((string-ci=? state "form") (TF:send-form))
      ((string-ci=? state "watch") (TF:prepare-watch))
      ((string-ci=? state "watching") (TF:do-watch))
      (else (CGI:bail-out "the send parameter is screwed"))))
      
(exit)
)