suzanne.soy/racket-pkg-website
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Split out jsonp

Browse Source
This commit is contained in:
Tony Garnock-Jones 2014-11-09 09:31:54 -05:00
parent f6fe653f66
commit ac13e7bc27
3 changed files with 71 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
src/jsonp-client.rkt Normal file
View File

@ -0,0 +1,52 @@
#lang racket/base
(provide jsonp-baseurl
jsonp-rpc!)
(require racket/match)
(require racket/format)
(require racket/port)
(require net/url)
(require net/uri-codec)
(require json)
(require "sessions.rkt")
(define jsonp-baseurl (make-parameter #f))
(define (jsonp-rpc! #:sensitive? [sensitive? #f]
#:include-credentials? [include-credentials? #t]
site-relative-url
original-parameters)
(define s (current-session))
(if sensitive?
(log-info "jsonp-rpc: sensitive request ~a" site-relative-url)
(log-info "jsonp-rpc: request ~a params ~a~a"
site-relative-url
original-parameters
(if include-credentials?
(if s
" +creds"
" +creds(missing)")
"")))
(define stamp (~a (inexact->exact (truncate (current-inexact-milliseconds)))))
(define callback-label (format "callback~a" stamp))
(define extraction-expr (format "^callback~a\\((.*)\\);$" stamp))
(let* ((parameters original-parameters)
(parameters (if (and include-credentials? s)
(append (list (cons 'email (session-email s))
(cons 'passwd (session-password s)))
parameters)
parameters))
(parameters (cons (cons 'callback callback-label) parameters)))
(define request-url
(string->url
(format "~a~a?~a"
(jsonp-baseurl)
site-relative-url
(alist->form-urlencoded parameters))))
(define-values (body-port response-headers) (get-pure-port/headers request-url))
(define raw-response (port->string body-port))
(match-define (pregexp extraction-expr (list _ json)) raw-response)
(define reply (string->jsexpr json))
(unless sensitive? (log-info "jsonp-rpc: reply ~a" reply))
reply))

66
src/main.rkt
View File

@ -4,18 +4,14 @@
(require racket/match)
(require racket/format)
(require racket/date)
(require racket/port)
(require racket/string)
(require net/uri-codec)
(require json)
(require web-server/servlet)
(require web-server/http/id-cookie)
(require web-server/http/cookie-parse)
(require web-server/http/request-structs)
(require "bootstrap.rkt")
(require "html-utils.rkt")
(require "packages.rkt")
(require "sessions.rkt")
(require "jsonp-client.rkt")
(define nav-index "Package Index")
(define nav-search "Search")
@ -33,6 +29,8 @@
;; "http://download.racket-lang.org/")
))
(jsonp-baseurl "https://pkgd.racket-lang.org")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-values (request-handler named-url)
@ -63,11 +61,6 @@
(define-syntax-rule (authentication-wrap/require-login #:request request body ...)
(authentication-wrap* #t request (lambda () body ...)))
(define current-session (make-parameter #f))
(define (current-email)
(define s (current-session))
(and s (session-email s)))
(define clear-session-cookie (make-cookie COOKIE
""
#:path "/"
@ -144,51 +137,6 @@
(list))))
(body)))))))
(define (jsonp-rpc! #:sensitive? [sensitive? #f]
#:include-credentials? [include-credentials? #t]
site-relative-url
original-parameters)
(define s (current-session))
(if sensitive?
(log-info "jsonp-rpc: sensitive request ~a" site-relative-url)
(log-info "jsonp-rpc: request ~a params ~a~a"
site-relative-url
original-parameters
(if include-credentials?
(if s
" +creds"
" +creds(missing)")
"")))
(define stamp (~a (inexact->exact (truncate (current-inexact-milliseconds)))))
(define callback-label (format "callback~a" stamp))
(define extraction-expr (format "^callback~a\\((.*)\\);$" stamp))
(let* ((parameters original-parameters)
(parameters (if (and include-credentials? s)
(append (list (cons 'email (session-email s))
(cons 'passwd (session-password s)))
parameters)
parameters))
(parameters (cons (cons 'callback callback-label) parameters)))
(define request-url
(string->url
(format "https://pkgd.racket-lang.org~a?~a"
site-relative-url
(alist->form-urlencoded parameters))))
(define-values (body-port response-headers) (get-pure-port/headers request-url))
(define raw-response (port->string body-port))
(match-define (pregexp extraction-expr (list _ json)) raw-response)
(define reply (string->jsexpr json))
(unless sensitive? (log-info "jsonp-rpc: reply ~a" reply))
reply))
(define (authenticate-with-server! email password code)
(jsonp-rpc! #:sensitive? #t
#:include-credentials? #f
"/jsonp/authenticate"
(list (cons 'email email)
(cons 'passwd password)
(cons 'code code))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define ((generic-input type) name [initial-value ""] #:placeholder [placeholder #f])
@ -262,6 +210,14 @@
(p ,error-message))))
,(form-group 4 5 (primary-button "Log in")))))))
(define (authenticate-with-server! email password code)
(jsonp-rpc! #:sensitive? #t
#:include-credentials? #f
"/jsonp/authenticate"
(list (cons 'email email)
(cons 'passwd password)
(cons 'code code))))
(define (process-login-credentials request)
(define-form-bindings request (email password))
(if (or (equal? (string-trim email) "")

9
src/sessions.rkt
View File

@ -1,6 +1,8 @@
#lang racket/base
(provide session-lifetime
(provide current-session
current-email
session-lifetime
(struct-out session)
create-session!
destroy-session!
@ -9,12 +11,17 @@
(require "randomness.rkt")
(define current-session (make-parameter #f))
(define session-lifetime (make-parameter (* 7 24 60 60 1000))) ;; one week in milliseconds
(struct session (key expiry email password) #:transparent)
(define sessions (make-hash))
(define (current-email)
(define s (current-session))
(and s (session-email s)))
(define (expire-sessions!)
(define now (current-inexact-milliseconds))
(for ((session-key (hash-keys sessions)))