shisaa.be (scheme)

why the hell we need to write tests for our code

(use test)

(use json-rpc-client)

(use test json-rpc-client)

(test-group "A name for your group" (test 1) (test 2) ... )

(test "Description of the test" "The result you want to see" (procedure to test))

(define input (open-input-string "some-string"))
(define output (open-output-string))
(define xbmc (json-rpc-server input output "2.0"))

(xbmc "Player.PlayPause")
(test "Call with only a method" "{\"jsonrpc\":\"2.0\",\"method\":\"Player.PlayPause\",\"id\":\"1\"}" (get-output-string output))

(xbmc "Player.PlayPause" playerid: 0)
(test "Call with a method and a one dimensional params" "{\"jsonrpc\":\"2.0\",\"method\":\"Player.PlayPause\",\"params\":{\"playerid\":0},\"id\":\"1\"}" (get-output-string output))

(define (test-server description expected method . params)
    (let ((output (open-output-string)))
        (apply (json-rpc-server input output "2.0") method params)
        (test
            message
            expected
            (get-output-string output))))

(define (test-server description expected method . params)

(let ((output (open-output-string))) ...

(let ((foo "a local string")
      (bar "another local string"))
     (cons foo bar))

(apply (json-rpc-server input output "2.0") method params)

(apply some-procedure '(1 2 3))

(apply some-procedure 4 5 "string" '(1 2 3))

(apply some-procedure '(4 5 "string" 1 2 3))

(test
    description
    expected
    (get-output-string output))

(test-server "Call with only a method" "{\"jsonrpc\":\"2.0\",\"method\":\"Player.PlayPause\",\"id\":\"1\"}" "Player.PlayPause")

{"jsonrpc":"2.0","method":"Player.PlayPause","id":"1"}

"{\"jsonrpc\":\"2.0\",\"method\":\"Player.PlayPause\",\"id\":\"1\"}"

(test-server "Call with a method and a one dimensional params" "{\"jsonrpc\":\"2.0\",\"method\":\"Player.PlayPause\",\"params\":{\"playerid\":0},\"id\":\"1\"}" "Player.PlayPause" playerid: 0)

(test-group "JSON-RPC string output checks"
    (test-server "Call with only a method" "{\"jsonrpc\":\"2.0\",\"method\":\"Player.PlayPause\",\"id\":\"1\"}" "Player.PlayPause")
    (test-server "Call with a method and a one dimensional params" "{\"jsonrpc\":\"2.0\",\"method\":\"Player.PlayPause\",\"params\":{\"playerid\":0},\"id\":\"1\"}" "Player.PlayPause" playerid: 0))

(use test json-rpc-client)

(define input (open-input-string "just-a-test-string"))
(define output (open-output-string))
(define xbmc (json-rpc-server input output "2.0"))

(define (test-server description expected method . params)
    (let ((output (open-output-string)))
        (apply (json-rpc-server input output "2.0") method params)
        (test
            description
            expected
            (get-output-string output))))

(test-group "JSON-RPC string output checks"
    (test-server "Call with only a method" "{\"jsonrpc\":\"2.0\",\"method\":\"Player.PlayPause\",\"id\":\"1\"}" "Player.PlayPause")
    (test-server "Call with a method and a one dimensional params" "{\"jsonrpc\":\"2.0\",\"method\":\"Player.PlayPause\",\"params\":{\"playerid\":0},\"id\":\"1\"}" "Player.PlayPause" playerid: 0))

(test-error "Non port call on input" (json-rpc-server "input" output "2.0"))

(test-error "Non port call on output" (json-rpc-server input "output" "2.0"))
(test-error "Non correct version number call" (json-rpc-server input output "3.0")))

(test-group "Non-port or non-version calls"
    (test-error "Non port call on input" (json-rpc-server "input" output "2.0"))
    (test-error "Non port call on output" (json-rpc-server input "output" "2.0"))
    (test-error "Non correct version number call" (json-rpc-server input output "3.0")))

(test-exit)

(use test json-rpc-client)

(define input (open-input-string "some-string"))
(define output (open-output-string))
(define xbmc (json-rpc-server input output "2.0"))

(define (test-server description expected method . params)
    (let ((output (open-output-string)))
        (apply (json-rpc-server input output "2.0") method params)
        (test
            description
            expected
            (get-output-string output))))

(test-group "JSON-RPC string output checks"
    (test-server "Call with only a method" "{\"jsonrpc\":\"2.0\",\"method\":\"Player.PlayPause\",\"id\":\"1\"}" "Player.PlayPause")
    (test-server "Call with a method and a one dimensional params" "{\"jsonrpc\":\"2.0\",\"method\":\"Player.PlayPause\",\"params\":{\"playerid\":0},\"id\":\"1\"}" "Player.PlayPause" playerid: 0))

(test-group "Non-port or non-version calls"
    (test-error "Non port call on input" (json-rpc-server "input" output "2.0"))
    (test-error "Non port call on output" (json-rpc-server input "output" "2.0"))
    (test-error "Non correct version number call" (json-rpc-server input output "3.0")))

(test-exit)

(compile -s -O2 -d1 json-rpc-client.scm -j json-rpc-client)
(compile -s json-rpc-client.import.scm -O2 -d0)

(install-extension
    'json-rpc
    '("json-rpc-client.so" "json-rpc-client.import.so")
    '((version "0.1.4")
      (documentation "json-rpc.html")))

((egg "json-rpc.egg")
 (synopsis "JSON RPC client/server implementation")
 (category web)
 (needs medea)
 (test-depends test)
 (doc-from-wiki)
 (license "BSD")
 (author "Tim van der Linden"))

(repo hg "https://bitbucket.org/Timusan/{egg-name}")
(uri targz "https://bitbucket.org/Timusan/{egg-name}/get/{egg-release}.tar.gz")
(release "0.1")
(release "0.1.1")

$ chicken-install

$ chicken-install -s

$ csi run.scm

$ openssl passwd -apr1 your-password-here

http://wiki.call-cc.org/eggref/4/json-rpc

http://wiki.call-cc.org/eggref/4/foo-bar

(define (json-rpc-server input output #!key (version "2.0"))
  (cond ((not (input-port? input)) (server-setup-arguments-error "input port" "input-port" (get-type input)))
         ((not (output-port? output)) (server-setup-arguments-error "output port" "ouput-port" (get-type output)))
         ((not (is-valid-version? version)) (server-setup-arguments-error "version" "2.0" version))
         (else
           (lambda (method . params) ... ))))

(define (is-valid-method? method)
  (string? method))

('these 'are 'five 'positional 'params) ;symbols
(these: are keyword: params) ;keywords

(define (are-valid-params? params)
  (list? params))

(define (server-setup-data-error type message)
  (signal
    (make-property-condition
      'exn 'message
      (sprintf "Cannot setup connection, the given ~S data is invalid. The ~S ~A"
      type type message))))

(define (json-rpc-server input output #!key (version "2.0"))
  (cond ((not (input-port? input)) (server-setup-arguments-error "input port" "input-port" (get-type input)))
         ((not (output-port? output)) (server-setup-arguments-error "output port" "ouput-port" (get-type output)))
         ((not (is-valid-version? version)) (server-setup-arguments-error "version" "2.0" version))
         (else
           (lambda (method . params)
             (cond ((not (is-valid-method? method)) (server-setup-data-error "method" "can only be a string."))
                    ((not (are-valid-params? params)) (server-setup-data-error "params" "can only be a vector or an alist."))
                    (else ... ))))))

(define xbmc (json-rpc-server input output))

(xbmc "Player.PlayPause" playerid: 0)

(
  (jsonrpc . "2.0")
  (method . "Player.PlayPause")
  (params
    (playerid . 0)
  )
  (id . 1)
)

(jsonrpc . "2.0")

(cons 'jsonrpc version)

(cons 'id 1)

(cons
    (cons 'jsonrpc version)
    (cons 'id 1))

((jsonrpc . version) id . 1)

((jsonrpc . version)(id . 1))

('id . 1)

(cons
    (cons 'jsonrpc version)
    (cons
        (cons 'id 1) '()))

((jsonrpc . "2.0") (id . 1))

(list
    (cons 'jsonrpc version)
    (cons 'id 1))

(cons
    (cons 'jsonrpc version)
    (cons
        (cons 'method "Player.PlayPause")
        (cons
            (cons 'id 1) '())))

(list
    (cons 'jsonrpc version)
    (cons 'method "Player.PlayPause")
    (cons 'id 1))

((jsonrpc . "2.0") (method . "Player.PlayPause") (id . 1))

(
  (params
    (playerid . 0)
  )
  (jsonrpc . "2.0")
  (method . "Player.PlayPause")
  (id . 1)
)

(list (cons 'jsonrpc version)
      (cons 'method "Player.PlayPause")
      (if (null? params) '() (cons 'params 'theparams))
      (cons 'id 1))

(define params #t)

(list (cons 'jsonrpc 'version)
      (cons 'method "Player.PlayPause")
      (if (null? params) '() (cons 'params 'theparams))
      (cons 'id 1))

((jsonrpc . version) (method . "Player.PlayPause") (params . theparams) (id . 1))

(define params '())

(list (cons 'jsonrpc 'version)
      (cons 'method "Player.PlayPause")
      (if (null? params) '() (cons 'params 'theparams))
      (cons 'id 1))

((jsonrpc . version) (method . "Player.PlayPause") () (id . 1))

(remove
    null?
    (list
        (cons 'jsonrpc 'version)
        (cons 'method "Player.PlayPause")
        (if (null? params)
            '()
            (cons 'params 'theparams))
        (cons 'id 1)))

((jsonrpc . version) (method . "Player.PlayPause") (id . 1))

(use extras srfi-1)

(define (json-rpc-server input output #!key (version "2.0"))
  (cond ((not (input-port? input)) (server-setup-arguments-error "input port" "input-port" (get-type input)))
         ((not (output-port? output)) (server-setup-arguments-error "output port" "ouput-port" (get-type output)))
         ((not (is-valid-version? version)) (server-setup-arguments-error "version" "2.0" version))
         (else
           (lambda (method . params)(
            (cond ((not (is-valid-method? method)) (server-setup-data-error "method" "can only be a string."))
                  ((not (are-valid-params? params)) (server-setup-data-error "params" "can only be a vector or an alist."))
                  (else
                    (remove
                        null?
                        (list
                            (cons 'jsonrpc version)
                            (cons 'method method)
                            (if (null? params) '() (cons 'params 'theparams))
                            (cons 'id "1"))))))))))

(define (build-params params)
    (if (keyword? (car params)) 
        (build-alist params)
        (list->vector (build-vector params))))

(first: "string" second: "string" third: "string")

((first . "string") (second . "string") (third . "string"))

(cons
    (cons (car params) (car (cdr params)))
    (cons
        (cons (car (cdr (cdr params))) (car (cdr (cdr (cdr params)))))
        (cons
            (cons (car (cdr (cdr (cdr (cdr params)))))(car (cdr (cdr (cdr (cdr (cdr params)))))))
            '())))

'(1 2 3)

(define (addone list)
    (if (null? list)
        '()
        (cons (+ (car list) 1) (addone (cdr list)))))

(addone '(1 2 3))

(2 3 4)

(if (null? list))

(cons (+ (car list) 1) (addone (cdr list)))

(cons (+ 1 1) (addone '(2 3)))

(cons (+ (car list) 1) (addone (cdr list)))

(cons (+ 2 1) (addone '(3)))

(cons (+ (car list) 1) (addone (cdr list)))

(cons (+ 3 1) (addone '()))

(if (null? params) '())

'()

(cons (+ 3 1) (addone '()))

(cons (+ 3 1) '())

(cons 4 '())

(cons (+ 2 1) (addone '(3)))

(cons 3 (4 . '()))

(cons (+ 1 1) (addone '(2 3)))

(cons  2 '(3 4 '()))

'(2 3 4)

(define (build-alist params)
    (if (null? params) 
    '()
    (cons
        (cons
            (car params)
            (car (cdr params)))
        (build-alist (cdr (cdr params))))))

(cons
    (cons
        (car params)
        (car (cdr params)))
    (build-alist (cdr (cdr params))))

(build-alist '(first: "string" second: "string" third: "string"))

((first: . "string") (second: . "string") (third: . "string"))

(define (build-params params)
    (if (keyword? (car params)) 
        (build-alist params)
        (list->vector (build-vector params))))

(define (build-vector params)
  (if (null? params)
      '()
      (cons
        (symbol->string(car params))
        (build-vector (cdr params)))))

(define (json-rpc-server input output #!key (version "2.0"))
(cond ((not (input-port? input)) (server-setup-arguments-error "input port" "input-port" (get-type input)))
  ((not (output-port? output)) (server-setup-arguments-error "output port" "ouput-port" (get-type output)))
  ((not (is-valid-version? version)) (server-setup-arguments-error "version" "2.0" version))
  (else
   (lambda (method . params)
     (cond ((not (is-valid-method? method)) (server-setup-data-error "method" "can only be a string."))
       ((not (are-valid-params? params)) (server-setup-data-error "params" "can only be a vector or an alist."))
       (else
        (remove null? (list (cons 'jsonrpc version)
                        (cons 'method method)
                        (if (null? params) '()
                            (cons 'params (build-params params)))
                            (cons 'id "1")))
              input 
              output))))))

(define (build-params params)
    (if (keyword? (car params)) 
        (build-alist params)
        (list->vector (build-vector params))))

(define (build-alist params)
    (if (null? params) 
        '()
        (cons
            (cons
                (car params)
                (car (cdr params)))
            (build-alist (cdr (cdr params))))))

(define (build-vector params)
    (if (null? params)
        '()
        (cons
            (symbol->string(car params))
            (build-vector (cdr params)))))

(use extras srfi-1 medea)

(define (send-request request output)
    (write-json request output))

(define (json-rpc-server input output #!key (version "2.0"))
(cond ((not (input-port? input)) (server-setup-arguments-error "input port" "input-port" (get-type input)))
  ((not (output-port? output)) (server-setup-arguments-error "output port" "ouput-port" (get-type output)))
  ((not (is-valid-version? version)) (server-setup-arguments-error "version" "2.0" version))
  (else
   (lambda (method . params)
     (cond ((not (is-valid-method? method)) (server-setup-data-error "method" "can only be a string."))
       ((not (are-valid-params? params)) (server-setup-data-error "params" "can only be a vector or an alist."))
       (else
        (send-request (remove null? (list (cons 'jsonrpc version)
                        (cons 'method method)
                        (if (null? params) '()
                            (cons 'params (build-params params)))
                            (cons 'id "1")))
                        output)))))))

(import chicken scheme)

(module json-rpc-client
    (json-rpc-server)
    (import chicken scheme)

    ... ; the whole egg code ; ...

)

pacman -S chicken

{"jsonrpc": "2.0", "method": "subtract", "params": [42, 23], "id": 1}

{"jsonrpc": "2.0", "method": "Player.PlayPause", "params": { "playerid": 0 }, "id": 1}

"This is a string"

#("foo" "bar")

((foo . bar) (faa . bor))

(use medea)

.q

chicken-install medea

(read-json datum)
(write-json datum)

(read-json "{\"jsonrpc\": \"2.0\", \"method\": \"Player.PlayPause\", \"params\": { \"playerid\": 0 }, \"id\": 1}")

((jsonrpc . "2.0")(method . "Player.PlayPause")(params (playerid . 0))(id . 1))

(jsonrpc . "2.0")

(method . "Player.PlayPause")

(id . 1)

(params . (playerid . 0))

(cons "foo" "faa")

("foo" . "faa")

(cons "foo" '("faa" "fii"))

("foo" "faa" "fii")

   ----> "foo"
   |
("foo" . "bar")             -----> '()
           |                |
           ----> ("bar" '())
                    |
                    ----> "bar"

("bar" '())

(
  (jsonrpc . "2.0")
  (method . "Player.PlayPause")
  (params
    (playerid . 0)
  )
  (id . 1)
)

(write-json datum)

(write-json '((jsonrpc . "2.0")(mathod . "Player.PlayPause")(params (playerid . 0))(id . 1)))

(define (json-rpc-server input output version) ... )

(define (json-rpc-server input output #!key (version "2.0")) ... )

(input-port? port)

(output-port? port)

(define (is-valid-version? version)
  (string=? version "2.0"))

(define (json-rpc-server input output #!key (version "2.0"))
(cond ((input-port? input))
       ((output-port? output))
       ((is-valid-version? version))) ... )

(define (server-setup-arguments-error type expected given)
  (signal
    (make-property-condition
      'exn 'message
        (sprintf "Cannot setup connection, the ~S is invalid. Excepted ~A type but got ~A."
          type expected given))))

(use extras)

(write "foo (bar)")

"foo (bar)"

(display "foo (bar)")

foo (bar)

(cond ((input-port? input)))

(cond ((input-port? input) (server-setup-arguments-error "input port" "input-port" (get-type input))))

(cond ((not (input-port? input)) (server-setup-arguments-error "input port" "input-port" (get-type input))))

(define (json-rpc-server input output #!key (version "2.0"))
  (cond ((not (input-port? input)) (server-setup-arguments-error "input port" "input-port" (get-type input)))
         ((not (output-port? output)) (server-setup-arguments-error "output port" "ouput-port" (get-type output)))
         ((not (is-valid-version? version)) (server-setup-arguments-error "version" "2.0" version))) ... )

(define (get-type x)
(cond ((input-port? x) "an input port")
       ((output-port? x) "an output port")
       ((number? x) "a mumber")
       ((pair? x) "a pair")
       ((string? x) "a string")
       ((list? x) "a list")
       ((vector? x) "a vector")
       ((boolean? x) "a boolean")
       (else
         ("something unknown"))))

(define xbmc (json-rpc-server valid-input "foobar"))

((not (input-port? input)) (server-setup-arguments-error "input port" "input-port" (get-type input)))

((not (output-port? output)) (server-setup-arguments-error "output port" "ouput-port" (get-type output)))

(get-type "foobar")

((string? x) "a string")

((not (output-port? output)) (server-setup-arguments-error "output port" "ouput-port" "a string"))

"Cannot setup connection, the output-port is invalid. Excepted output-port type but got a string."

(define xbmc (json-rpc-server valid-input-port valid-output-port))

(define (json-rpc-server input output #!key (version "2.0"))
(cond ((not (input-port? input)) (server-setup-arguments-error "input port" "input-port" (get-type input)))
       ((not (output-port? output)) (server-setup-arguments-error "output port" "ouput-port" (get-type output)))
       ((not (is-valid-version? version)) (server-setup-arguments-error "version" "2.0" version))
       (else ...

(define (foo arguments))

(define foo
    (lambda (arguments)))

(define (json-rpc-server input output #!key (version "2.0"))
  (cond ((not (input-port? input)) (server-setup-arguments-error "input port" "input-port" (get-type input)))
         ((not (output-port? output)) (server-setup-arguments-error "output port" "ouput-port" (get-type output)))
         ((not (is-valid-version? version)) (server-setup-arguments-error "version" "2.0" version))
         (else
           (lambda (method . params)))) ... )

shisaa.be (scheme)

The Scheme programming language AKA The CHICKEN hens nest - Part 3

Chapter 3 - Wrapping the egg

Why tests?

Testing in CHICKEN

Local scoping?

The setup file

The meta file

The release-info file

Doing a test install

Publishing & Documentation

The end

The Scheme programming language AKA The CHICKEN hens nest - Part 2

Chapter 2 - Laying the egg

Let us dive in!

Building the request object

Recursion

Back to our egg

Sending over the data

Defining and exporting

Licensing

Looking ahead

The Scheme programming language AKA The CHICKEN hens nest - Part 1

Chapter 1 - A Schemey world of wonder

So what will we see in this first chapter?

Preface

Less cheesy preface

What is CHICKEN?

How do you "get" CHICKEN?

csc

csi

chicken-install

Outlining the Egg

(CHICKEN) Data types

Medea, the JSON egg

car, cdr & cons

Hatching an egg

What is exception handling?

What is this Lambda?