WebGate

Check-in [e657ff967b]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:suspended resource and error handling tweaks
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: e657ff967bba947cd5b23bb8c1308eaa3f393cdc
User & Date: murphy 2011-09-25 01:51:06
Context
2011-10-02
20:40
proper static linkage setup check-in: 091ba753c1 user: murphy tags: trunk
2011-09-25
01:51
suspended resource and error handling tweaks check-in: e657ff967b user: murphy tags: trunk
2011-09-23
21:26
added an example for suspensions check-in: e9f3970674 user: murphy tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to webgate.scm.

653
654
655
656
657
658
659


660


661
662
663
664
665
666
667
...
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713



714
715
716
717
718
719
720
721
722
723
724
725


726
727
728
729
730
731
732
733
734



735
736
737
738
739
740
741
742
743
744
745
746
747
...
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835

;;; Central server routine

(define (handle-request getenv input-port output-port)
  (write-response
   (handle-exceptions
    exn (begin


	  (print-error-message exn)


	  (print-call-chain)
	  (make-error-response
	   500 "The server encountered an internal error handling the request."))
    (let ((parameters (make-hash-table))
	  (method (or (getenv "REQUEST_METHOD") "GET"))
	  (path (string-split (uri-decode (or (getenv "PATH_INFO") "")) "/")))
      (or
................................................................................
	  404 "The requested resource was not found by the server.")))
       (make-response 204 '()))))
   output-port))

)

(module webgate-suspend
  (max-suspended-resources
   suspended-resource-handler
   suspended
   send/suspend)
  (import
   scheme chicken
   srfi-1 srfi-18 srfi-69
   data-structures webgate-utils webgate-core)

;;; Support for suspended computations (and directly related stuff)

(define max-suspended-resources
  (make-parameter 1024))




(define suspended-resource-handler
  (let ((handler
	 (let ((mutex (make-mutex 'suspended-resources))
	       (table (make-hash-table
		       #:test string-ci=? #:hash string-ci-hash
		       #:size (max-suspended-resources))))
	   (lambda (resume/uuid)
	     (dynamic-wind
		 (cut mutex-lock! mutex)
		 (if (procedure? resume/uuid)
		     (lambda ()


		       (let ((size (hash-table-size table)))
			 (when (>= size (max-suspended-resources))
			   (let ((uuids (sort! (hash-table-keys table)
					       (lambda (a b)
						 (< (uuid-time a)
						    (uuid-time b))))))
			     (for-each
			      (cut hash-table-delete! table <>)
			      (take uuids



				    (inexact->exact (ceiling (/ size 2))))))))
		       (let ((uuid (make-uuid 'time)))
			 (hash-table-set! table uuid resume/uuid)
			 uuid))
		     (lambda ()
		       (hash-table-ref/default table resume/uuid #f)))
		 (cut mutex-unlock! mutex))))))
    (case-lambda
     (()
      handler)
     ((proc)
      (set! handler proc)))))

................................................................................
   request-parameter-handler
   resource-context current-resource-context resource-context?
   resource-context-getenv resource-context-return
   response make-response response?
   collect-response make-html-response make-error-response
   response-status response-status-message
   resource-handler define-resource resource-uri
   max-suspended-resources
   suspended-resource-handler
   suspended
   send/suspend
   webgate-main)
  (import
   scheme chicken
   webgate-core webgate-suspend webgate-cgi webgate-scgi tcp)







>
>
|
>
>







 







|












>
>
>



|
|
|
<



<
|
>
>
|
|
|
|
|
<
|
|
|
>
>
>
|
|
|
|
<
|







 







|







653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
...
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726

727
728
729

730
731
732
733
734
735
736
737

738
739
740
741
742
743
744
745
746
747

748
749
750
751
752
753
754
755
...
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843

;;; Central server routine

(define (handle-request getenv input-port output-port)
  (write-response
   (handle-exceptions
    exn (begin
	  (when (uncaught-exception? exn)
	    (set! exn (uncaught-exception-reason exn)))
	  (print-error-message
	   exn (current-error-port)
	   (sprintf "[~a] Request Handling Error" (current-seconds)))
	  (print-call-chain)
	  (make-error-response
	   500 "The server encountered an internal error handling the request."))
    (let ((parameters (make-hash-table))
	  (method (or (getenv "REQUEST_METHOD") "GET"))
	  (path (string-split (uri-decode (or (getenv "PATH_INFO") "")) "/")))
      (or
................................................................................
	  404 "The requested resource was not found by the server.")))
       (make-response 204 '()))))
   output-port))

)

(module webgate-suspend
  (max-suspended-resources max-suspended-resources-load
   suspended-resource-handler
   suspended
   send/suspend)
  (import
   scheme chicken
   srfi-1 srfi-18 srfi-69
   data-structures webgate-utils webgate-core)

;;; Support for suspended computations (and directly related stuff)

(define max-suspended-resources
  (make-parameter 1024))

(define max-suspended-resources-load
  (make-parameter 0.75))

(define suspended-resource-handler
  (let ((handler
	 (let ((mutex (make-mutex 'suspended-resources)))
	   (mutex-specific-set!
	    mutex (make-hash-table #:test string-ci=? #:hash string-ci-hash))

	   (lambda (resume/uuid)
	     (dynamic-wind
		 (cut mutex-lock! mutex)

		 (lambda ()
		   (let ((table (mutex-specific mutex)))
		     (if (procedure? resume/uuid)
			 (let ((size (hash-table-size table))
			       (max-size (max-suspended-resources)))
			   (when (>= size max-size)
			     (let* ((max-load (max-suspended-resources-load))
				    (num-drop (- size (* max-size max-load))))

			       (for-each
				(cut hash-table-delete! table <>)
				(take
				 (sort! (hash-table-keys table)
					(lambda (a b)
					  (< (uuid-time a) (uuid-time b))))
				 (inexact->exact (ceiling num-drop))))))
			   (let ((uuid (make-uuid 'time)))
			     (hash-table-set! table uuid resume/uuid)
			     uuid))

			 (hash-table-ref/default table resume/uuid #f))))
		 (cut mutex-unlock! mutex))))))
    (case-lambda
     (()
      handler)
     ((proc)
      (set! handler proc)))))

................................................................................
   request-parameter-handler
   resource-context current-resource-context resource-context?
   resource-context-getenv resource-context-return
   response make-response response?
   collect-response make-html-response make-error-response
   response-status response-status-message
   resource-handler define-resource resource-uri
   max-suspended-resources max-suspended-resources-load
   suspended-resource-handler
   suspended
   send/suspend
   webgate-main)
  (import
   scheme chicken
   webgate-core webgate-suspend webgate-cgi webgate-scgi tcp)