(use srfi-1)
(use srfi-13)
(use srfi-19)
(use gauche.parameter)
(use gauche.sequence)
(use graphics.gd)
(use math.const)
(use util.list)

(define-constant HTTP_CONTINUE                      100)
(define-constant HTTP_SWITCHING_PROTOCOLS           101)
(define-constant HTTP_PROCESSING                    102)
(define-constant HTTP_OK                            200)
(define-constant HTTP_CREATED                       201)
(define-constant HTTP_ACCEPTED                      202)
(define-constant HTTP_NON_AUTHORITATIVE             203)
(define-constant HTTP_NO_CONTENT                    204)
(define-constant HTTP_RESET_CONTENT                 205)
(define-constant HTTP_PARTIAL_CONTENT               206)
(define-constant HTTP_MULTI_STATUS                  207)
(define-constant HTTP_MULTIPLE_CHOICES              300)
(define-constant HTTP_MOVED_PERMANENTLY             301)
(define-constant HTTP_MOVED_TEMPORARILY             302)
(define-constant HTTP_SEE_OTHER                     303)
(define-constant HTTP_NOT_MODIFIED                  304)
(define-constant HTTP_USE_PROXY                     305)
(define-constant HTTP_TEMPORARY_REDIRECT            307)
(define-constant HTTP_BAD_REQUEST                   400)
(define-constant HTTP_UNAUTHORIZED                  401)
(define-constant HTTP_PAYMENT_REQUIRED              402)
(define-constant HTTP_FORBIDDEN                     403)
(define-constant HTTP_NOT_FOUND                     404)
(define-constant HTTP_METHOD_NOT_ALLOWED            405)
(define-constant HTTP_NOT_ACCEPTABLE                406)
(define-constant HTTP_PROXY_AUTHENTICATION_REQUIRED 407)
(define-constant HTTP_REQUEST_TIME_OUT              408)
(define-constant HTTP_CONFLICT                      409)
(define-constant HTTP_GONE                          410)
(define-constant HTTP_LENGTH_REQUIRED               411)
(define-constant HTTP_PRECONDITION_FAILED           412)
(define-constant HTTP_REQUEST_ENTITY_TOO_LARGE      413)
(define-constant HTTP_REQUEST_URI_TOO_LARGE         414)
(define-constant HTTP_UNSUPPORTED_MEDIA_TYPE        415)
(define-constant HTTP_RANGE_NOT_SATISFIABLE         416)
(define-constant HTTP_EXPECTATION_FAILED            417)
(define-constant HTTP_UNPROCESSABLE_ENTITY          422)
(define-constant HTTP_LOCKED                        423)
(define-constant HTTP_FAILED_DEPENDENCY             424)
(define-constant HTTP_UPGRADE_REQUIRED              426)
(define-constant HTTP_INTERNAL_SERVER_ERROR         500)
(define-constant HTTP_NOT_IMPLEMENTED               501)
(define-constant HTTP_BAD_GATEWAY                   502)
(define-constant HTTP_SERVICE_UNAVAILABLE           503)
(define-constant HTTP_GATEWAY_TIME_OUT              504)
(define-constant HTTP_VERSION_NOT_SUPPORTED         505)
(define-constant HTTP_VARIANT_ALSO_VARIES           506)
(define-constant HTTP_INSUFFICIENT_STORAGE          507)
(define-constant HTTP_NOT_EXTENDED                  510)

(define *time-template* "~d/~b/~Y:~H:~M:~S ~z") ; 24/Oct/2006:20:14:10 +0900
(define *regexp-safe*
  #/^(\S+) (\S+) (\S+) \[([^\]]+)\]/)
(define *regexp-combined* ; LogFormat "%h %l %u %t \"%r\" %>s %b \"%{Referer}i\" \"%{User-Agent}i\"" combined
  #/^(\S+) (\S+) (\S+) \[([^\]]+)\] \"([^\"]*)\" (\S+) (\S+) \"([^\"]*)\" \"([^\"]*)\"/)
(define *regexp-common* ; LogFormat "%h %l %u %t \"%r\" %>s %b" common
  #/^(\S+) (\S+) (\S+) \[([^\]]+)\] \"([^\"]*)\" (\S+) (\S+)/)

(define-class <access> ()
  ((i :init-keyword :i)
   (host :init-keyword :host)
   (user :init-keyword :user)
   (time :init-keyword :time)
   (request :init-keyword :request)
   (status :init-keyword :status)
   (nbytes :init-keyword :nbytes)
   (referer :init-keyword :referer)
   (ua :init-keyword :ua)))

(define-method write-object ((c <access>) port)
  (format port "#~d ~a - ~a [~a] \"~a\" ~a ~a"
		  (ref c 'i)
		  (ref c 'host)
		  (ref c 'user)
		  (date->string (ref c 'time) *time-template*)
		  (ref c 'request)
		  (ref c 'status)
		  (ref c 'nbytes)))

(define-method object-equal? ((x <access>) (y <access>))
  (= (ref x 'i) (ref y 'i)))

(define-macro (define-http-status name . rest)
  (let ((method (string->symbol (format #f "http-status-~a?" name))))
	`(begin
	   (define-method ,method ((status <integer>))
		 (and (memq status (list ,@rest))
			  #t))
	   (define-method ,method ((a <access>))
		 (,method (ref a 'status))))))

(define-http-status success
  HTTP_OK
  HTTP_CREATED
  HTTP_ACCEPTED
  HTTP_NON_AUTHORITATIVE
  HTTP_NO_CONTENT
  HTTP_RESET_CONTENT
  HTTP_PARTIAL_CONTENT
  HTTP_MULTI_STATUS
  )
(define-http-status redirect
  HTTP_MULTIPLE_CHOICES
  HTTP_MOVED_PERMANENTLY
  HTTP_MOVED_TEMPORARILY
  HTTP_SEE_OTHER
  HTTP_NOT_MODIFIED
  HTTP_USE_PROXY
  HTTP_TEMPORARY_REDIRECT
  )
(define-http-status error
  HTTP_BAD_REQUEST
  HTTP_UNAUTHORIZED
  HTTP_PAYMENT_REQUIRED
  HTTP_FORBIDDEN
  HTTP_NOT_FOUND
  HTTP_METHOD_NOT_ALLOWED
  HTTP_NOT_ACCEPTABLE
  HTTP_PROXY_AUTHENTICATION_REQUIRED
  HTTP_REQUEST_TIME_OUT
  HTTP_CONFLICT
  HTTP_GONE
  HTTP_LENGTH_REQUIRED
  HTTP_PRECONDITION_FAILED
  HTTP_REQUEST_ENTITY_TOO_LARGE
  HTTP_REQUEST_URI_TOO_LARGE
  HTTP_UNSUPPORTED_MEDIA_TYPE
  HTTP_RANGE_NOT_SATISFIABLE
  HTTP_EXPECTATION_FAILED
  HTTP_UNPROCESSABLE_ENTITY
  HTTP_LOCKED
  HTTP_FAILED_DEPENDENCY
  HTTP_UPGRADE_REQUIRED
  HTTP_INTERNAL_SERVER_ERROR
  HTTP_NOT_IMPLEMENTED
  HTTP_BAD_GATEWAY
  HTTP_SERVICE_UNAVAILABLE
  HTTP_GATEWAY_TIME_OUT
  HTTP_VERSION_NOT_SUPPORTED
  HTTP_VARIANT_ALSO_VARIES
  HTTP_INSUFFICIENT_STORAGE
  HTTP_NOT_EXTENDED
  )

(define date-hour=?
  (every-pred
   (lambda (d1 d2)
	 (= (date-year d1)
		(date-year d2)))
   (lambda (d1 d2)
	 (= (date-month d1)
		(date-month d2)))
   (lambda (d1 d2)
	 (= (date-day d1)
		(date-day d2)))
   (lambda (d1 d2)
	 (= (date-hour d1)
		(date-hour d2)))))

(define (time-hour=? t1 t2)
  (date-hour=? (time-utc->date t1) (time-utc->date t2)))

(define (date<? d1 d2) (time<? (date->time-utc d1) (date->time-utc d2)))

(define access_log-line-max (make-parameter 10240))

(define (preprocess-port iport)
  (let pp ((i 0)
		   (line (read-line iport)))
	(rxmatch-cond
	  (test (eof-object? line) (values #f #f #f))
	  (test (< (access_log-line-max) (string-length line))
			(rxmatch-cond
			  ((rxmatch *regexp-safe* line)
			   (#f h l u t)
			   (values i line (string->date t *time-template*)))
			  (else
			   (pp (+ i 1) (read-line iport)))))
	  ((rxmatch *regexp-combined* line)
	   (#f h l u t r s b rfr ua)
	   (values i line (string->date t *time-template*)))
	  ((rxmatch *regexp-common* line)
	   (#f h l u t r s b)
	   (values i line (string->date t *time-template*)))
	  (else
	   (pp (+ i 1) (read-line iport))))))

(define (port->accesses iport)
  (receive (i line start)
	  (preprocess-port iport)
	(if (not i)
		(values #f #f #f)
		(let lp ((i i)
				 (line line)
				 (end start)
				 (result '()))
		  (rxmatch-cond
			(test (eof-object? line)
				  (values (reverse! result) start end))
			(test (< 10240 (string-length line))
				  (rxmatch-cond
					((rxmatch *regexp-safe* line)
					 (#f h l u t)
					 (let ((temp (string->date t *time-template*)))
					   (lp (+ i 1)
						   (read-line iport)
						   temp
						   (cons (make <access>
								   :i i
								   :host h
								   :user u
								   :time temp)
								 result))))
					(else
					 (lp (+ i 1) (read-line iport) end result))))
			((rxmatch *regexp-combined* line)
			 (#f h l u t r s b rfr ua)
			 (let ((temp (string->date t *time-template*)))
			   (lp (+ i 1)
				   (read-line iport)
				   temp
				   (cons (make <access>
						   :i i
						   :host h
						   :user u
						   :time temp
						   :request r
						   :status (string->number s)
						   :nbytes b
						   :referer (if (string=? "-" rfr) #f rfr)
						   :ua ua)
						 result))))
			((rxmatch *regexp-common* line)
			 (#f h l u t r s b)
			 (let ((temp (string->date t *time-template*)))
			   (lp (+ i 1)
				   (read-line iport)
				   temp
				   (cons (make <access>
						   :i i
						   :host h
						   :user u
						   :time temp
						   :request r
						   :status (string->number s)
						   :nbytes b)
						 result))))
			(else
			 (lp (+ i 1) (read-line iport) end result)))))))

(define (transition accesses cmp . param)
  (let-keywords* param ((limit 3600)
						(tolerance 10))
	(let ((limit (make-time 'time-duration 0 limit))
		  (tolerance (make-time 'time-duration 0 tolerance)))
	  (let lp ((accesses (stable-sort
						  accesses
						  (lambda (x y)
							(time<? (date->time-utc (ref x 'time))
									(date->time-utc (ref y 'time))))))
			   (leaves '())
			   (result '()))
		(if (null? accesses)
			(reverse! result)
			(receive (a rest)
				(car+cdr accesses)
			  (let ((t (date->time-utc (ref a 'time))))
				(receive (succ leaves)
					(call/cc
					 (lambda (cont)
					   (fold2
						(lambda (b seed leaves)
						  (if (member b leaves)
							  (values seed leaves)
							  (let ((u (date->time-utc (ref b 'time))))
								(cond ((null? seed)
									   (cond ((time<? limit (time-difference u t))
											  (cont seed leaves))
											 ((cmp a b)
											  (values (list b) leaves))
											 (else
											  (values '() leaves))))
									  ((time<? tolerance (time-difference u (date->time-utc (ref (car seed) 'time))))
									   (cont seed leaves))
									  ((cmp a b)
									   (values (cons b seed) leaves))
									  (else
									   (values seed leaves))))))
						'()
						(delete a leaves)
						rest)))
				  (lp rest
					  (append succ leaves)
					  (if (null? succ)
						  result
						  (cons (cons a (reverse succ)) result)))))))))))

(define (classify accesses cmp . param)
  (let ((transitions (apply transition accesses cmp param)))
	(let lp ((accesses accesses)
			 (transitions transitions)
			 (result '()))
	  (if (null? accesses)
		  (reverse! result)
		  (receive (a rest)
			  (car+cdr accesses)
			(cond ((find (lambda (x) (equal? a (car x))) transitions)
				   => (lambda (t)
						(letrec ((node (car t))
								 (extend-forest
								  (lambda (forest)
									(fold2
									 (lambda (tree seed proc)
									   (cond ((proc tree)
											  => (lambda (t)
												   (values (cons t seed)
														   identity)))
											 (else
											  (values (cons tree seed)
													  proc))))
									 '()
									 extend-tree
									 (reverse forest))))
								 (extend-tree
								  (lambda (tree)
									(cond ((pair? tree)
										   (receive (root next)
											   (car+cdr tree)
											 (receive (result proc)
												 (extend-forest next)
											   (and (eq? identity proc)
													(cons root result)))))
										  ((equal? tree node)
										   t)
										  (else
										   #f)))))
						  (lp rest
							  (remove (lambda (x) (equal? a (car x))) transitions)
							  (receive (extended proc)
								  (extend-forest result)
								(if (eq? identity proc)
									extended
									(cons t result)))))))
				  (else
				   (lp rest
					   transitions
					   (cons a result)))))))))

(define-syntax match-request-uri
  (syntax-rules ()
	((_ rx ...)
	 (lambda (a)
	   (let ((request (ref a 'request)))
		 (rxmatch-cond
		   ((rxmatch rx request)
			(#f uri)
			uri)
		   ...
		   (else
			#f
			)))))))

(define request-uri
  (match-request-uri
   #/^HEAD\s+(\/\S*)\s+HTTP\/[0-9]\.[0-9]$/
   #/^GET\s+(\/\S*)\s+HTTP\/[0-9]\.[0-9]$/
   #/^POST\s+(\/\S*)\s+HTTP\/[0-9]\.[0-9]$/))

(define (retrieved-uri accesses . param)
  (map
   car
   (sort
	(hash-table->alist
	 (fold
	  (lambda (a table)
		(cond ((and (http-status-success? a)
					(request-uri a))
			   => (lambda (uri)
					(hash-table-update! table uri (cut + 1 <>) 0)
					table))
			  (else
			   table)))
	  (make-hash-table 'string=?)
	  accesses))
	(lambda (x y) (< (cdr x) (cdr y))))))

(define (build-bar accesses start end)
  (let ((uri-set (retrieved-uri accesses))
		(groups (group-collection accesses
								  :key (cut ref <> 'time)
								  :test date-hour=?))
		(h (make-time 'time-duration 0 (* 60 60))))
	(let lp ((t start)
			 (h-max 0)
			 (bar '()))
	  (cond ((and (time<? end t) (not (time-hour=? end t)))
			 (values h-max (reverse! bar)))
			((find (lambda (g) (time-hour=? t (date->time-utc (ref (car g) 'time)))) groups)
			 =>
			 (lambda (g)
			   (let sub ((set uri-set)
						 (g g)
						 (h-temp 0)
						 (result '()))
				 (if (null? set)
					 (lp (add-duration t h)
						 (max h-max h-temp)
						 (cons (cons t (reverse! result)) bar))
					 (receive (uri rest)
						 (car+cdr set)
					   (receive (g0 g1)
						   (partition (lambda (a)
										(and-let* ((u (request-uri a)))
										  (string=? u uri)))
									  g)
						 (let ((n0 (length g0)))
						   (sub rest g1 (+ h-temp n0) (cons n0 result)))))))
			   ))
			(else
			 (lp (add-duration t h)
				 h-max
				 (cons (cons t (make-list (length uri-set) 0))
					   bar))
			 )))))

(define (draw-graph accesses start end cmp . param)
  (let-keywords* param ((width 1024)
						(height 480)
						(origin-x 20)
						(origin-y 40)
						(uri-width-max 480)
						(font "/usr/share/fonts/truetype/ttf-bitstream-vera/Vera.ttf")
						(with-bar #t)
						(with-plot #f)
						(output #f)
						)
	(let* ((start (date->time-utc start))
		   (end (date->time-utc end))
		   (duration (time-second (time-difference end start)))
		   (uri-set (retrieved-uri accesses))
		   (uri-num (length uri-set))
		   )
	  (if (= 0 uri-num)
		  (error "no retrieved uri")
		  (let* ((x (- width (* 2 origin-x)))
				 (y (- height (* 2 origin-y)))
				 (dy/2 (inexact->exact (round (/ y uri-num 2))))
				 (branches (transition accesses cmp))
				 (im (gd-image-create (+ width uri-width-max) height))
				 (white (color-allocate! im #xff #xff #xff))
				 (black (color-allocate! im 0 0 0))
				 (blue  (color-allocate! im 0 0 #xff))
				 (green (color-allocate! im 0 #xff 0))
				 (gray  (color-allocate! im #xdd #xdd #xdd))
				 )
			(define (time->x t)
			  (+ origin-x (inexact->exact (round (/ (* x (time-second (time-difference t start))) duration))))
			  )
			(define (uri-index->y k . rest)
			  (let-keywords* rest ((position 'center))
				(case position
				  ((center)
				   (+ origin-y dy/2 (inexact->exact (round (/ (* y k) uri-num)))))
				  ((bottom)
				   (+ origin-y (inexact->exact (round (/ (* y (+ k 1)) uri-num)))))))
			  )
			(define (plot a)
			  (let ((t (date->time-utc (ref a 'time)))
					(k (and-let* ((uri (request-uri a)))
						 (list-index (lambda (u) (string=? uri u)) uri-set))))
				(when k
				  (let ((x0 (time->x t))
						(y0 (uri-index->y k)))
					(rectangle! im (- x0 1) (- y0 1) (+ x0 1) (+ y0 1) blue))))
			  )
			(define (arrow branch)
			  (receive (a leaves)
				  (car+cdr branch)
				(let ((t0 (date->time-utc (ref a 'time)))
					  (k0 (and-let* ((uri (request-uri a)))
							(list-index (cut string=? uri <>) uri-set))))
				  (when k0
					(let ((x0 (time->x t0))
						  (y0 (uri-index->y k0)))
					  (for-each
					   (lambda (b)
						 (let ((t1 (date->time-utc (ref b 'time)))
							   (k1 (and-let* ((uri (request-uri b)))
									 (list-index (cut string=? uri <>) uri-set))))
						   (when k1
							 (let ((x1 (time->x t1))
								   (y1 (uri-index->y k1)))
							   (line! im x0 y0 x1 y1 green)))))
					   leaves)))))
			  )
			(define (draw-uri)
			  (let ((style (append-map
							(lambda (c)
							  (make-list 4 (color-resolve! im (car c) (cadr c) (caddr c))))
							'((#xdd #xdd #xdd)
							  (#xff #xff #xff)))))
				(set-style! im style))
			  (with-ft-font/fg/pt/angle
			   font black 8 0
			   (lambda ()
				 (fold2
				  (lambda (uri k w)
					(let ((y (uri-index->y k)))
					  (line! im origin-x y (+ origin-x x) y gdStyled)
					  (receive (_0 p _1 _2)
						  (string! im width (+ 4 y) uri)
						(values (+ k 1) (max w (car p))))
					  ))
				  0
				  width
				  uri-set)))
			  )
			(define (draw-time t . rest)
			  (let-keywords* rest ((line #t)
								   (HMS #f)
								   (Ymd #t))
				  (let ((x (time->x t)))
					(when line
					  (line! im x origin-y x (+ y origin-y 2) gray))
					(let ((date (time-utc->date t)))
					  (when HMS
						(with-ft-font/fg/pt/angle
						 font black 8 0
						 (lambda ()
						   (string! im x (+ y origin-y 10) (date->string date "~T")))))
					  (when Ymd
						(with-ft-font/fg/pt/angle
						 font black 10 0
						 (lambda ()
						   (string! im x (+ y origin-y (+ 10 10 2)) (date->string date "~Y/~m/~d")))))
					  )))
			  )
			(define (draw-bar)
			  (receive (h-max bars)
				  (build-bar accesses start end)
				(with-ft-font/fg/pt/angle
				 font black 6 pi/4
				 (lambda ()
				   (for-each-with-index
					(lambda (k bar)
					  (receive (t clist)
						  (car+cdr bar)
						(let* ((n (apply + clist))
							   (h (make-time 'time-duration 0 (* 60 60)))
							   (d (time-utc->date t))
							   (d0 (make-date 0 0 0 (date-hour d) (date-day d) (date-month d) (date-year d) (* 9 60 60)))
							   (t0 (date->time-utc d0))
							   (t1 (add-duration t0 h))
							   (x0 (time->x t0))
							   (x1 (time->x t1)))
						  (let ((top-x (max origin-x x0))
								(top-y (- height origin-y (inexact->exact (round (/ (* y n) h-max)))))
								(bot-x (min (+ x origin-x) x1))
								(bot-y (- height origin-y)))
							(rectangle! im
										(+ top-x 2) top-y
										(- bot-x 2) bot-y
										gray
										:filled #t)
							(when (< (/ h-max 2) n)
							  (string! im
									   (inexact->exact (round (/ (+ top-x bot-x) 2)))
									   (- top-y 1)
									   (number->string n)))
							))))
					bars))))
			  )
			(define (with-ruler start end thunk)
			  (receive (_ right-x)
				  (if with-plot
					  (draw-uri)
					  (values #f #f))
				(thunk)
				(draw-time start :line #f :HMS #t :Ymd #t)
				(let ((s (time-utc->date start))
					  (d (make-time 'time-duration 0 (* 24 60 60))))
				  (let lp ((t (date->time-utc (make-date 0 0 0 0 (date-day s) (date-month s) (date-year s) (* 9 60 60)))))
					(let ((u (add-duration t d)))
					  (if (time<=? end u)
						  'done
						  (begin
							(draw-time u)
							(lp u))))))
				(draw-time end :line #f :HMS #t :Ymd #f)
				(line! im origin-x (+ y origin-y) (- width origin-x) (+ y origin-y) black)
				(line! im origin-x origin-y origin-x (- height origin-y) black)
				(let* ((w (if right-x
							  (min (+ right-x origin-x) (+ width uri-width-max))
							  width))
					   (dst (gd-image-create w height)))
				  (gd-image-copy dst im 0 0 0 0 w height)
				  dst))
			  )
			(fill! im width height white)
			(let ((dst (with-ruler
						start end
						(lambda ()
						  (when with-bar
							(draw-bar))
						  (when with-plot
							(for-each plot accesses)
							(for-each arrow branches))
						  ))))
			  (if output
				  (save-as dst output)
				  dst))				
			)))))