(module server-core mzscheme
  (require (lib "servlet-helpers.ss" "web-server")
           (file "serialise.ss")
           (file "protocol.ss"))
  (provide (all-defined))
  
  ;; XML-RPC Environment
  ;; Bindings for the XML-RPC server are modeled as a simple
  ;; hash-table. We shouldn't need a more complex environment
  ;; model for an XML-RPC server; the namespace is flat.
  (define environment (make-hash-table))
  
  ;; add-handler : symbol (any -> any) -> void
  ;; Adds a new identifier and associated procedure to the
  ;; environment.
  (define (add-handler id fun)
    (hash-table-put! environment id fun))
  
  ;; handler-exists? : symbol -> (U #t #f)
  ;; Checks to see if the requisite handler is bound in the environment.
  (define (handler-exists? id)
    (hash-table-get environment id (lambda () #f)))
  
  ;; invoke-handler : sym (list-of any) -> methodResponse
  ;; Invokes the given handler on the data passed in from
  ;; the call if the handler exists.
  ;;
  ;; There might be other checks we could do at this point
  ;; to keep things from falling over in an ugly way; for
  ;; the moment, I do an arity check, which is more than the
  ;; spec calls for, I suspect.
  (define (invoke-handler name args)
    (let* ([fun (hash-table-get environment name)]
           [arity (procedure-arity fun)]
           [arg-length (length args)])
      (cond
        [(= arity arg-length)
         (let ([serialised-result
                (serialise (apply fun args))])
           `(methodResponse
             (params 
              (param
               ;; Is there an inconsistent wrapping of 'value'
               ;; around this?
               ,serialised-result))))]
        [else
         (make-handler-fault 
          (format "You invoked '~a' with ~a parameters; '~a' expects ~a."
                  name arg-length name arity)
          101
          )])
      ))
  
  ;; make-handler-fault : string num -> methodResponse
  ;; Makes the XML-RPC 'fault' method response.
  ;; The error codes thrown by this library should be chosen
  ;; in a less arbitrary way, and documented.
  (define (make-handler-fault string code)
    (let ([errorHash (make-hash-table)])
      (hash-table-put! 
       errorHash 'faultString string)
      (hash-table-put! 
       errorHash 'faultCode code)
      `(methodResponse (fault (value ,(serialise errorHash))))))
  
    ;; 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))))

  ;; handle-xmlrpc-servlet-request* : request -> methodResponse
  ;; Returns the value of the computation requested by the user,
  ;; or returns a fault.
  (define (handle-xmlrpc-servlet-request* request)
    (let ([call (decode-xmlrpc-call
                 (extract-xmlrpc-bindings request))])
      
      (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)))))
  
  )