(module server-core mzscheme
  (require "serialise.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))))))
  
  )