Commit 91edfc64 authored by Dave Griffiths's avatar Dave Griffiths
Browse files

Merge branch 'master' of github.com:nebogeo/symbai

parents 0dae8d5a 3c7c5c6f
#!/bin/bash
./server.scm 8889
...@@ -56,25 +56,27 @@ ...@@ -56,25 +56,27 @@
(define (register-proc r) (list-ref r 1)) (define (register-proc r) (list-ref r 1))
; builds the argument list from the registered requests ; builds the argument list from the registered requests
(define (request-run reg req) (define (request-run reg req request)
(apply (register-proc reg) (apply (register-proc reg)
(map (cons
(lambda (arg) request
;; if it's registered as an argument (map
(if (req-has-arg? (register-req reg) (car arg)) (lambda (arg)
;; send it through plain ;; if it's registered as an argument
(filter-string (cdr arg)) (if (req-has-arg? (register-req reg) (car arg))
;; send it with the argument name ;; send it through plain
(cons (string->symbol (filter-string (symbol->string (car arg)))) (filter-string (cdr arg))
(filter-string (cdr arg))))) ;; send it with the argument name
(req-args req)))) (cons (string->symbol (filter-string (symbol->string (car arg))))
(filter-string (cdr arg)))))
(req-args req)))))
;; look up this request in the registry and run it ;; look up this request in the registry and run it
(define (request-dispatch reg req) (define (request-dispatch reg req request)
(cond (cond
((null? reg) (printf "unknown command ~a~n" (req-name req)) ((null? reg) (printf "unknown command ~a~n" (req-name req))
(pluto-response (string-append "unknown command " (symbol->string (req-name req))))) (pluto-response (string-append "unknown command " (symbol->string (req-name req)))))
((equal? (req-name (register-req (car reg))) (req-name req)) ((equal? (req-name (register-req (car reg))) (req-name req))
(request-run (car reg) req)) (request-run (car reg) req request))
(else (else
(request-dispatch (cdr reg) req)))) (request-dispatch (cdr reg) req request))))
...@@ -21,6 +21,7 @@ ...@@ -21,6 +21,7 @@
web-server/servlet web-server/servlet
web-server/servlet-env web-server/servlet-env
web-server/http/response-structs web-server/http/response-structs
racket/match
"scripts/request.ss" "scripts/request.ss"
"scripts/logger.ss" "scripts/logger.ss"
"scripts/json.ss" "scripts/json.ss"
...@@ -36,7 +37,7 @@ ...@@ -36,7 +37,7 @@
;;(unsafe!) ;;(unsafe!)
;;(define setuid (get-ffi-obj 'setuid #f (_fun _int -> _int))) ;;(define setuid (get-ffi-obj 'setuid #f (_fun _int -> _int)))
(define db-name "client/htdocs/mongoose.db") (define db-name "client/htdocs/symbai.db")
(define db (db-open db-name)) (define db (db-open db-name))
(open-log "log.txt") (open-log "log.txt")
...@@ -47,14 +48,25 @@ ...@@ -47,14 +48,25 @@
(register (register
(req 'ping '()) (req 'ping '())
(lambda () (lambda (req)
(pluto-response (scheme->txt '("hello"))))) (pluto-response (scheme->txt '("hello")))))
(register
(req 'upload '())
(lambda (req)
(match (bindings-assq #"binary" (request-bindings/raw req))
((struct binding:file (id filename headers content))
(with-output-to-file
(string-append "files/" (bytes->string/utf-8 filename)) #:exists 'replace
(lambda ()
(write-bytes content)))))
(pluto-response (scheme->txt '("ok")))))
;; http://localhost:8888/mongoose?fn=sync&table=sync&entity-type=mongoose&unique-id=dave1234&dirty=1&version=0&next:varchar=%22foo%22&blah:int=20 ;; http://localhost:8888/mongoose?fn=sync&table=sync&entity-type=mongoose&unique-id=dave1234&dirty=1&version=0&next:varchar=%22foo%22&blah:int=20
(register (register
(req 'sync '(table entity-type unique-id dirty version)) (req 'sync '(table entity-type unique-id dirty version))
(lambda (table entity-type unique-id dirty version . data) (lambda (req table entity-type unique-id dirty version . data)
(pluto-response (pluto-response
(scheme->txt (scheme->txt
(check-for-sync (check-for-sync
...@@ -67,28 +79,28 @@ ...@@ -67,28 +79,28 @@
(register (register
(req 'entity-versions '(table)) (req 'entity-versions '(table))
(lambda (table) (lambda (req table)
(pluto-response (pluto-response
(scheme->txt (scheme->txt
(entity-versions db table))))) (entity-versions db table)))))
(register (register
(req 'entity '(table unique-id)) (req 'entity '(table unique-id))
(lambda (table unique-id) (lambda (req table unique-id)
(pluto-response (pluto-response
(scheme->txt (scheme->txt
(send-entity db table unique-id))))) (send-entity db table unique-id)))))
(register (register
(req 'entity-types '(table)) (req 'entity-types '(table))
(lambda (table) (lambda (req table)
(pluto-response (pluto-response
(scheme->txt (scheme->txt
(get-all-entity-types db table))))) (get-all-entity-types db table)))))
(register (register
(req 'entity-csv '(table type)) (req 'entity-csv '(table type))
(lambda (table type) (lambda (req table type)
(let ((r (csv db table type))) (let ((r (csv db table type)))
(msg "--------------------------------------- csv request for" type "[" r "]") (msg "--------------------------------------- csv request for" type "[" r "]")
(pluto-response (pluto-response
...@@ -97,8 +109,8 @@ ...@@ -97,8 +109,8 @@
)) ))
(define (start request) (define (start request)
(msg "request")
(let ((values (url-query (request-uri request)))) (let ((values (url-query (request-uri request))))
(msg "got a request" request)
(if (not (null? values)) ; do we have some parameters? (if (not (null? values)) ; do we have some parameters?
(let ((name (assq 'fn values))) (let ((name (assq 'fn values)))
(if name ; is this a well formed request? (if name ; is this a well formed request?
...@@ -108,7 +120,8 @@ ...@@ -108,7 +120,8 @@
(filter (filter
(lambda (v) (lambda (v)
(not (eq? (car v) 'fn))) (not (eq? (car v) 'fn)))
values))) values))
request)
(pluto-response "could't find a function name"))) (pluto-response "could't find a function name")))
(pluto-response "malformed thingy")))) (pluto-response "malformed thingy"))))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment