Skip to content
Fetching contributors…
Cannot retrieve contributors at this time
executable file 158 lines (145 sloc) 5.9 KB
#!/usr/bin/env gosh
;; -*- mode: scheme; coding: utf-8 -*-
;; Communicate to kahua application server
;; This cgi script is kicked by httpd and pass through the request
;; to one of kahua servers.
;; The server to connect is determined as follows:
;;
;; 1. If PATH_INFO is given, its first component is regarded as a
;; app-server type, and the rest is used as a cgsid. Query
;; parameters are ignored. If more than one app-servers of
;; that type are running, the client can't specify which
;; server it will connect.
;; 2. If "x-kahua-cgsid" query parameter is given, the cgsid is
;; taken from it and the app-server worker id is extracted.
;; 3. Otherwise, just connect to the supervisor and let it decide
;; which app-server to handle the request.
(add-load-path "##libdir##")
(use srfi-1)
(use srfi-13)
(use www.cgi)
(use util.list)
(use gauche.parameter)
(use kahua.util)
(use kahua.config)
(use kahua.protocol.http)
(use kahua.protocol.worker)
##ADDITIONAL_LIBS##
(define-constant *LOG-PREFIX* "~Y ~T ~P[~$]: ")
(define-constant *OMIT-FIELDS*
'("PATH" "SERVER_SIGNATURE" "SERVER_ADMIN" "DOCUMENT_ROOT" "KAHUA_DEFAULT_SITE"))
(define-constant *TERMINATION-SIGNALS* (sys-sigset-add! (make <sys-sigset>) SIGTERM SIGINT SIGHUP SIGPIPE))
(define (compose-reply header body)
(let1 header (kahua-header->http-header header)
(list (if (assoc-ref-car header "content-type")
header
(assoc-set! header "content-type" *default-content-type*))
body)))
;; determine dispatch destination.
;; returns: worker-type cont-gsid
(define (dispatch-destination params path-info)
(let1 cgsid (cgi-get-parameter "x-kahua-cgsid" params)
(cond ((null? path-info) (values #f cgsid))
((pair? (cdr path-info))
(values (car path-info) (or cgsid (cadr path-info))))
(else (values (car path-info) cgsid)))))
;; construct absolute uri for the server root.
;; note that we can only guess the protocol scheme.
(define (server-uri)
(let ((scheme (if (cgi-get-metavariable "HTTPS") "https" "http"))
(name (or (and-let* ((v (cgi-get-metavariable "SERVER_NAME"))
(m (#/^(.+?)(?:\:\d+)?$/ v)))
(m 1))
"localhost"))
(port (cond ((cgi-get-metavariable "SERVER_PORT") => x->integer)
(else 80))))
(format "~a://~a~a"
scheme name
(if (or (and (string=? scheme "http") (= port 80))
(and (string=? scheme "https") (= port 443)))
""
#`":,port"))))
;; prepare headers and dispatch the request to the appropriate server,
;; then receives the reply and forward it to the client.
(define (send-reply param path-info worker-uri)
(receive (worker-type cont-gsid)
(dispatch-destination param path-info)
(let* ((state-gsid (cgi-get-parameter "x-kahua-sgsid" param))
(remote-addr (or (and-let* ((xff (cgi-get-metavariable "HTTP_X_FORWARDED_FOR"))
(hops (string-split xff #/\, */)))
(and (pair? hops) (car hops)))
(cgi-get-metavariable "REMOTE_ADDR")))
(worker-uri (and worker-uri #`",(string-join worker-uri \"/\" 'prefix)/"))
(header (kahua-worker-header worker-type path-info
:server-uri (server-uri)
:worker-uri worker-uri
:metavariables (cgi-metavariables)
:sgsid state-gsid
:cgsid cont-gsid
:remote-addr remote-addr
:bridge (cgi-get-metavariable "SCRIPT_NAME"))))
(for-each (lambda (f)
(when (file-exists? f)
(sys-chmod f #o660)))
(cgi-temporary-files))
(receive (header body) (talk-to-worker cont-gsid header param)
(compose-reply header body)))))
(define (publisher params)
(define pair->list (compose list car+cdr))
(define (override-metavariables mv-list)
(let loop ((accum '())
(cmv (or (cgi-metavariables)
(map! pair->list (sys-environ->alist))))
(mv-list mv-list))
(if (null? cmv)
(append mv-list accum)
(let* ((e (car cmv))
(k (car e)))
(cond ((assoc k mv-list) =>
(lambda (e) (loop (cons e accum) (cdr cmv) (alist-delete k mv-list equal?))))
((member k *OMIT-FIELDS*) (loop accum (cdr cmv) mv-list))
(else (loop (cons e accum) (cdr cmv) mv-list)))))))
(receive (scheme host port worker worker-uri paths)
(parse-path-info (path->path-info (cgi-get-metavariable "PATH_INFO")))
(let* ((path-info (if worker (cons worker paths) '()))
(override-mv `(,@(if (eq? scheme 'https) '(("HTTPS" "on")) '())
,@(if host `(("SERVER_NAME" ,host)) '())
,@(if port `(("SERVER_PORT" ,port)) '())
("PATH_INFO"
,(if (pair? path-info) (path-info->abs-path path-info) "/")))))
(kahua:log-format "override-mv: ~s" override-mv)
(parameterize ((cgi-metavariables (override-metavariables override-mv)))
(send-reply params path-info worker-uri)))))
(define (main args)
(define (output-handler sexp)
(let1 out (current-output-port)
(send-http-header out (car sexp))
(display "\r\n" out)
(send-http-body out (cgi-output-character-encoding) (cadr sexp))))
(kahua-common-init #f #f)
(kahua:log-open (kahua-cgilogpath "kahua-cgi.log") :prefix *LOG-PREFIX*)
(call/cc
(lambda (bye)
(define (cleanup) (for-each sys-unlink (cgi-temporary-files)))
(define (finish-server sig)
(kahua:log-format (sys-signal-name sig))
(cleanup) (bye 0))
##CGIBEGIN##
(guard (e (else (kahua:log-format "error(ignored): ~a" (slot-ref e 'message))))
(set-signal-handler! *TERMINATION-SIGNALS* finish-server)
(cgi-main publisher
:merge-cookies #t
:on-error cgi-error-proc
:output-proc output-handler
:part-handlers `((#t file+name ,(kahua-tmpbase)))
))
##CGIEND##
(cleanup)
(bye 0))))
(define (cgi-error-proc e)
(let ((errmsg (condition-ref e 'message))
(status (kahua-error->status e)))
(kahua:log-format "CGI error caught: ~a" errmsg)
`((("status" ,(http-status-string status #f))
("content-type" "text/html"))
,(current-error-page status errmsg))))
Something went wrong with that request. Please try again.