(module xmlrpc-servlet mzscheme
  
  (require (lib "unitsig.ss")
           (lib "servlet-sig.ss" "web-server")
           (file "server-core.ss")
           (file "protocol.ss"))
  
  (provide (all-from (lib "unitsig.ss"))
           (all-from (lib "servlet-sig.ss" "web-server"))
           add-handler
           handle-xmlrpc-requests
           handle-xmlrpc-request*)
  
  ;; SYNTAX: handle-xmlrpc-requests
  ;; Expands to the servlet^ unit/sig that handles incoming
  ;; XML-RPC requests. Pushes down the necessity of
  ;; passing in the initial-request.
  (define-syntax handle-xmlrpc-requests 
    (lambda (stx)
      (syntax-case stx ()
        [(_)
         #`(unit/sig ()
             (import servlet^)
             (handle-xmlrpc-request* initial-request))])))
  
  
  ;; extract-xmlrpc-bindings : request -> string
  ;; The bindings come in all kinds of messed up, it seems.
  ;; This *must* be tested against clients other than ours
  ;; to decide whether this is a sensible way to handle the bindings
  ;; or not.
  (define (extract-xmlrpc-bindings request)
    ;; struct:request looks like:
    ;;   method uri headers/raw bindings/raw
    ;;   host-ip host-port client-ip
    (let ([raw-bindings (request-bindings/raw request)])
      ;; This string-append is because the bindings come in
      ;; mangled for XML-RPC content; it seems like the webserver
      ;; tears it up in a syntactically bogus location (w.r.t. the
      ;; structure of the XML document.)
      (apply string-append
             (map (lambda (b)
                    (format "~a~a"
                            (binding-id b)
                            (binding:form-value b)))
                  raw-bindings))))

  ;; These are values that are part of Matt's
  ;; exploration of the memory usage behavior...
  (define gc-count 1)
  (define gc-interval 10)
  
  ;; handle-xmlrpc-request* : request -> methodResponse
  ;; Returns the value of the computation requested by the user,
  ;; or returns a fault.
  (define (handle-xmlrpc-request* request)
    (let ([call (decode-xmlrpc-call
                 (extract-xmlrpc-bindings request))])
      
      ;; This is a kludge to constrain memory consumption.
      ;; Something, somewhere, is leaking a collectable
      ;; resource.
      (set! gc-count (modulo (add1 gc-count) gc-interval))
      (if (zero? gc-count) (collect-garbage))
      
      (let ([name (rpc-call-name call)]
            [args (rpc-call-args call)])
        (if (handler-exists? name)
            (invoke-handler name args)
            (make-handler-fault 
             (format "No handler found on server for '~a'" name)
             100)))))
  
  )