;;
;;  Access to CGI request metavariables,
;;  as described in RFC 3875 "The Common Gateway Interface (CGI) 1.1".
;;
;;  Copyright 2013 Ivan Raikov.
;;
;;  Based in part on the Haskell Network.CGI library by Peter Thiemann
;;  and Bjorn Bringert.
;;


(module cgi-environment

	(

          auth-type
          content-type
          content-length
          gateway-interface
          path-info
          path-translated
          query-string
          remote-addr
          remote-host
          remote-user
          remote-ident
          request-method
          script-name
          server-name
          server-software
          server-port
          server-protocol

          )

	(import scheme chicken)

	(require-extension data-structures srfi-1 utf8 utf8-srfi-13 utf8-srfi-14)
        (require-extension typeclass input-classes)

        (require-library lexgen)
        (import (prefix lexgen lex:))
        (import (only lexgen <Token> <CharLex> 
                      Input->Token Token->CharLex 
                      ))

	(require-library abnf)
        (import (only abnf <CoreABNF> CharLex->CoreABNF))

        (require-library cgi-grammar)
        (import (only cgi-grammar <CGI> CoreABNF->CGI))
        

        ;; helper macro for mutually-recursive parser definitions
        (define-syntax vac
          (syntax-rules ()
            ((_ fn) (lambda args (apply fn args)))))


        (define char-list-<Input>
          (make-<Input> null? car cdr))
        
        (define char-list-<Token>
          (Input->Token char-list-<Input>))
        
        (define char-list-<CharLex>
          (Token->CharLex char-list-<Token>))
        
        (define char-list-<CoreABNF>
          (CharLex->CoreABNF char-list-<CharLex>))
        
        (define char-list-<CGI> (CoreABNF->CGI char-list-<CoreABNF>))
        
        (import-instance (<CGI> char-list-<CGI> p.) )

        ;; CGI Variable Definitions
        (define (AUTH_TYPE)           (get-environment-variable (->string 'AUTH_TYPE)))
        (define (CONTENT_TYPE)        (get-environment-variable (->string 'CONTENT_TYPE)))
        (define (CONTENT_LENGTH)      (get-environment-variable (->string 'CONTENT_LENGTH)))
        (define (GATEWAY_INTERFACE)   (get-environment-variable (->string 'GATEWAY_INTERFACE)))
        (define (PATH_INFO)           (get-environment-variable (->string 'PATH_INFO)))
        (define (PATH_TRANSLATED)     (get-environment-variable (->string 'PATH_TRANSLATED)))
        (define (QUERY_STRING)        (get-environment-variable (->string 'QUERY_STRING)))
        (define (REMOTE_ADDR)         (get-environment-variable (->string 'REMOTE_ADDR)))
        (define (REMOTE_HOST)         (get-environment-variable (->string 'REMOTE_HOST)))
        (define (REMOTE_USER)         (get-environment-variable (->string 'REMOTE_USER)))
        (define (REMOTE_IDENT)        (get-environment-variable (->string 'REMOTE_IDENT)))
        (define (REQUEST_METHOD)      (get-environment-variable (->string 'REQUEST_METHOD)))
        (define (SCRIPT_NAME)         (get-environment-variable (->string 'SCRIPT_NAME)))
        (define (SERVER_NAME)         (get-environment-variable (->string 'SERVER_NAME)))
        (define (SERVER_SOFTWARE)     (get-environment-variable (->string 'SERVER_SOFTWARE)))
        (define (SERVER_PORT)         (get-environment-variable (->string 'SERVER_PORT)))
        (define (SERVER_PROTOCOL)     (get-environment-variable (->string 'SERVER_PROTOCOL)))

        ;; CGI Variable Parsing

        (define (parse cont p)
          (lambda (s)  (p cont (lambda (x) (error 'parse "CGI meta variable parser error" x)) s)))


        (define (meta-variable s p . rest)
          (let-optionals rest ((f identity))
                         ((parse (compose f car) p) `(() ,(string->list s)))))
        

        (define (auth-type)
          (meta-variable
           (AUTH_TYPE)
           p.auth-type
           (lambda (x) (let ((v (car x))) (and (not (string-null? v)) (string->symbol v))))
           ))
        
        (define (content-length)
          (meta-variable
           (CONTENT_LENGTH)
           p.content-length
           (lambda (x) (let ((v (car x)))
                           (and (not (string-null? v)) (string->number v))))
           ))
        
        (define (content-type)
          (meta-variable 
           (CONTENT_TYPE)
           p.content-type
           reverse
           ))
        
        (define (gateway-interface)
          (meta-variable 
           (GATEWAY_INTERFACE)
           p.gateway-interface
           ))
        
        (define (path-info)
          (meta-variable
           (PATH_INFO)
           p.path-info
           (lambda (x) (let ((v (car x))) (or (and (string-null? v) (list)) v)))
           ))
        
        (define (path-translated)
          (PATH_TRANSLATED))
        
        (define (query-string)
          (let ((s (QUERY_STRING)))
            (and s (meta-variable
                    (string->list s)
                    p.query-string
                    ))
            ))
        
        (define (remote-addr)
          (meta-variable
           (REMOTE_ADDR)
           p.remote-addr
           ))
        
        (define (remote-host)
          (meta-variable
           (REMOTE_HOST)
           p.remote-host
           (lambda (x) (let ((v (car x))) (or (and (string-null? v) (list)) v)))
           ))
        
        (define (remote-ident)
          (REMOTE_IDENT))
        
        (define (remote-user)
          (REMOTE_USER))
        
        (define (request-method)
          (let ((m (REQUEST_METHOD)))
            (and m (meta-variable 
                    m p.request-method
                    car
                    ))
            ))
        
        (define (script-name)
          (meta-variable
           (SCRIPT_NAME)
	     p.path-info
	     (lambda (x) (let ((v (car x))) (or (and (string-null? v) (list)) v)))
	     ))

        (define (server-name)
          (meta-variable
           (SERVER_NAME)
           p.server-name
           ))
        
        (define (server-port)
          (meta-variable
           (SERVER_PORT)
           p.server-port
           (lambda (x) (let ((v (car x))) (and (not (string-null? v)) (string->number v))))
           ))

        (define (server-protocol)
          (meta-variable
           (SERVER_PROTOCOL)
           p.server-protocol
           (lambda (x) (and (not (null? x)) (cons (string->symbol (car x)) (cdr x))))
           ))
        
        (define (server-software)
          (meta-variable
           (SERVER_SOFTWARE)
           p.server-software
           ))

)