| 123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246 |
- #lang racket/base
- (require db
- json
- racket/async-channel
- racket/fasl
- racket/port
- racket/serialize
- redis
- threading
- web-server/dispatch
- web-server/http
- web-server/http/response
- web-server/safety-limits
- web-server/web-server
- xml)
- (provide
- start)
- ;; db ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (define *db*
- (virtual-connection
- (connection-pool
- (lambda ()
- (postgresql-connect #:database "hello_world"
- #:user "benchmarkdbuser"
- #:password "benchmarkdbpass"
- #:server "tfb-database")))))
- ;; cache ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (define *redis*
- (make-redis-pool
- #:pool-size 32))
- (define (deserialize* bs)
- (deserialize (fasl->s-exp bs)))
- (define (serialize* v)
- (s-exp->fasl (serialize v)))
- ;; helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (define (response/bytes bs
- #:code [code 200]
- #:headers [headers null]
- #:mime-type [mime-type #"text/plain"])
- (define len:bs (string->bytes/utf-8 (number->string (bytes-length bs))))
- (response/output
- #:code code
- #:mime-type mime-type
- #:headers (cons (make-header #"Content-Length" len:bs) headers)
- (lambda (out)
- (write-bytes bs out))))
- (define (response/json e)
- (response/bytes
- #:mime-type #"application/json; charset=utf-8"
- (jsexpr->bytes e)))
- (define (response/xexpr xe)
- (response/bytes
- #:mime-type #"text/html; charset=utf-8"
- (call-with-output-bytes
- (lambda (out)
- (write-bytes #"<!DOCTYPE html>" out)
- (write-xexpr xe out)))))
- ;; world ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (serializable-struct world (id n)
- #:transparent)
- (define select-one-world
- (virtual-statement "SELECT id, randomnumber FROM world WHERE id = $1"))
- (define update-one-world
- (virtual-statement "UPDATE world SET randomnumber = $2 WHERE id = $1"))
- (define (random-world-id)
- (random 1 10001))
- (define (random-world-ids n)
- (for/list ([_ (in-range n)])
- (random-world-id)))
- (define (worlds-ref id)
- (for/first ([(id n) (in-query *db* select-one-world id)])
- (world id n)))
- (define (worlds-ref/random n)
- (for*/list ([id (in-list (random-world-ids n))]
- [(id n) (in-query *db* select-one-world id)])
- (world id n)))
- (define (worlds-update! rs)
- (for ([r (in-list rs)])
- (query-exec *db* update-one-world (world-id r) (world-n r))))
- (define (world->hash r)
- (hasheq 'id (world-id r)
- 'randomNumber (world-n r)))
- ;; fortune ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (struct fortune (id message)
- #:transparent)
- (define select-fortunes
- (virtual-statement "SELECT id, message FROM fortune"))
- (define (all-fortunes)
- (define fortunes
- (cons
- (fortune 0 "Additional fortune added at request time.")
- (for/list ([(id message) (in-query *db* select-fortunes)])
- (fortune id message))))
- (sort fortunes string<? #:key fortune-message))
- (define (fortune->table-row f)
- `(tr
- (td ,(number->string (fortune-id f)))
- (td ,(fortune-message f))))
- ;; web ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (define (parse-queries req)
- (or
- (and~> (request-bindings/raw req)
- (bindings-assq #"queries" _)
- (binding:form-value)
- (bytes->string/utf-8)
- (string->number)
- (min 500)
- (max 1))
- 1))
- (define-values (dispatch _url)
- (dispatch-rules
- [("plaintext")
- (lambda (_req)
- (response/bytes #"Hello, World!"))]
- [("json")
- (lambda (_req)
- (response/json
- (hasheq 'message "Hello, World!")))]
- [("db")
- (lambda (_req)
- (define world-id (random-world-id))
- (define world (worlds-ref world-id))
- (response/json
- (world->hash world)))]
- [("fortunes")
- (lambda (_req)
- (response/xexpr
- `(html
- (head
- (title "Fortunes"))
- (body
- (table
- (tr
- (th "id")
- (th "message"))
- ,@(map fortune->table-row (all-fortunes)))))))]
- [("queries")
- (lambda (req)
- (define n (parse-queries req))
- (define worlds (worlds-ref/random n))
- (response/json
- (map world->hash worlds)))]
- [("cached")
- (let ([local-cache (make-hasheqv)])
- (lambda (req)
- (define n (parse-queries req))
- (define worlds
- (hash-ref! local-cache n (lambda ()
- (call-with-redis-client *redis*
- (lambda (rc)
- (define k (format "worlds:~a" n))
- (cond
- [(redis-bytes-get rc k)
- => deserialize*]
- [else
- (define worlds (worlds-ref/random n))
- (begin0 worlds
- (redis-bytes-set! rc k (serialize* worlds)))]))))))
- (response/json
- (map world->hash worlds))))]
- [("updates")
- (lambda (req)
- (define n (parse-queries req))
- (define worlds
- (for/list ([r (in-list (worlds-ref/random n))]
- [n (in-list (random-world-ids n))])
- (struct-copy world r [n n])))
- (worlds-update! worlds)
- (response/json
- (map world->hash worlds)))]))
- (define (start host port tcp@)
- (define (app c req)
- (output-response c (dispatch req)))
- (define ch (make-async-channel))
- (define stop
- (serve
- #:dispatch app
- #:listen-ip host
- #:port port
- #:tcp@ tcp@
- #:confirmation-channel ch
- #:safety-limits (make-safety-limits
- #:max-concurrent 1000
- #:max-waiting 65535
- #:request-read-timeout 16
- #:response-timeout 16
- #:response-send-timeout 16)))
- (define ready-or-exn (sync ch))
- (when (exn:fail? ready-or-exn)
- (raise ready-or-exn))
- stop)
- (module+ main
- (require net/tcp-unit)
- (define stop (start "127.0.0.1" 8000 tcp@))
- (with-handlers ([exn:break? (λ (_) (stop))])
- (displayln "ready")
- (sync never-evt)))
|
