132 lines
4.5 KiB
Racket
132 lines
4.5 KiB
Racket
|
#lang racket
|
||
|
|
|
||
|
|
(require web-server/servlet
|
||
|
|
web-server/servlet-env)
|
||
|
|
|
||
|
|
(require "challenge.rkt")
|
||
|
|
(require "either.rkt")
|
||
|
|
(require "challenges.rkt")
|
||
|
|
(require "validate.rkt")
|
||
|
|
(require racket/format)
|
||
|
|
|
||
|
|
(define intro (file->string "intro.txt"))
|
||
|
|
|
||
|
|
; start: request -> response
|
||
|
|
; Consumes a request and produces a page that displays all of the
|
||
|
|
; web content.
|
||
|
|
(define (start request)
|
||
|
|
(define updated-challenges
|
||
|
|
(cond ((can-parse-attempt? (request-bindings request))
|
||
|
|
(process-attempt (request-bindings request)))
|
||
|
|
(else
|
||
|
|
challenges)))
|
||
|
|
(render-page updated-challenges))
|
||
|
|
|
||
|
|
; Produces true if bindings contains values for 'id and 'code
|
||
|
|
(define (can-parse-attempt? bindings)
|
||
|
|
(and (exists-binding? 'id bindings)
|
||
|
|
(exists-binding? 'code bindings)))
|
||
|
|
|
||
|
|
; The main piece of code for processing a request
|
||
|
|
; Takes care of all necesarry error handling and updates a challenge based on the results
|
||
|
|
(define (process-attempt bindings)
|
||
|
|
(define input-id (extract-binding/single 'id bindings))
|
||
|
|
(define result
|
||
|
|
(do
|
||
|
|
(<- id (parse-id input-id))
|
||
|
|
(let code (extract-binding/single 'code bindings))
|
||
|
|
(<- challenge (get-challenge id))
|
||
|
|
(let allowed (challenge-allowed challenge))
|
||
|
|
(<- validated-code (validate code allowed))
|
||
|
|
(run challenge validated-code)))
|
||
|
|
(reduce (add-response input-id 'fail) (add-response input-id 'success) result))
|
||
|
|
|
||
|
|
|
||
|
|
; Parse the id of the request
|
||
|
|
(define (parse-id id)
|
||
|
|
(define num (string->number id))
|
||
|
|
(if num
|
||
|
|
(right num)
|
||
|
|
(left "Error parsing challenge id, not a valid number")))
|
||
|
|
|
||
|
|
; Adds a result to a single challenge (1 arg curried)
|
||
|
|
(define (add-response id status)
|
||
|
|
(define id-num (string->number id))
|
||
|
|
(lambda (err)
|
||
|
|
(map (lambda (ch)
|
||
|
|
(if (equal? id-num (challenge-id ch))
|
||
|
|
(add-status status err ch)
|
||
|
|
ch))
|
||
|
|
challenges)))
|
||
|
|
|
||
|
|
; Tries to obtain a certain challenge
|
||
|
|
(define (get-challenge id)
|
||
|
|
(if (or (< id 0) (>= id (length challenges)))
|
||
|
|
(left "Bad challenge id given, stop hacking my platform >:(")
|
||
|
|
(right (list-ref challenges id))))
|
||
|
|
|
||
|
|
; Renders the entire page
|
||
|
|
(define (render-page challenges)
|
||
|
|
(response/xexpr
|
||
|
|
`(html (head
|
||
|
|
(title "Scheme Challenges!")
|
||
|
|
(link ((rel "stylesheet") (href "style.css")))
|
||
|
|
(link ((rel "shortcut icon") (href "favicon.ico") (type "image/x-icon"))))
|
||
|
|
(body
|
||
|
|
,(render-intro)
|
||
|
|
,(render-challenges challenges)
|
||
|
|
(div ((style "display: none;"))
|
||
|
|
(a ((href "sicp.jpg")) "Hidden url :o "))))))
|
||
|
|
|
||
|
|
; Renders the explanations etc
|
||
|
|
(define (render-intro)
|
||
|
|
`(div ((class "intro"))
|
||
|
|
(h2 "Scheme Programming Challenges")
|
||
|
|
(p ,intro)))
|
||
|
|
|
||
|
|
; Renders all challenges
|
||
|
|
(define (render-challenges challenges)
|
||
|
|
`(div ((class "challenges"))
|
||
|
|
,@(map render-challenge challenges)))
|
||
|
|
|
||
|
|
; Renders a single challenge
|
||
|
|
(define (render-challenge challenge)
|
||
|
|
(define status (challenge-status challenge))
|
||
|
|
(define err? (eq? status 'fail))
|
||
|
|
(define succ? (eq? status 'success))
|
||
|
|
`(div ((class "challenge"))
|
||
|
|
(h3 ,(string-append "Challenge " (number->string(challenge-id challenge))))
|
||
|
|
(p ,(challenge-description challenge))
|
||
|
|
(div ((class "input-str"))
|
||
|
|
"Allowed procedures, special-forms and variable names:")
|
||
|
|
(div ((class "output"))
|
||
|
|
,(apply ~a (challenge-allowed challenge) #:separator " | "))
|
||
|
|
(div ((class "input-str"))
|
||
|
|
"Given input:")
|
||
|
|
(div ((class "output"))
|
||
|
|
,(apply ~a (challenge-input challenge) #:separator " | "))
|
||
|
|
(div ((class "output-str"))
|
||
|
|
"Expected output:")
|
||
|
|
(div ((class "output"))
|
||
|
|
,(apply ~a (challenge-output challenge) #:separator " | "))
|
||
|
|
(form
|
||
|
|
(input ((name "id") (type "hidden") (value ,(number->string (challenge-id challenge)))))
|
||
|
|
(textarea ((name "code")))
|
||
|
|
(button ((type "submit")) "Get flag!"))
|
||
|
|
(div ((class "error") (style ,(if err? "" "display: none;")))
|
||
|
|
,(if (pair? (challenge-err challenge))
|
||
|
|
(apply ~a (challenge-err challenge) #:separator " | ")
|
||
|
|
(~a (challenge-err challenge))))
|
||
|
|
(div ((class "flag") (style ,(if succ? "" "display: none;")))
|
||
|
|
,(if succ?
|
||
|
|
(challenge-flag challenge)
|
||
|
|
"")))) ;TODO input is cleared after submission
|
||
|
|
|
||
|
|
; #:listen-ip #f
|
||
|
|
; #:command-line? #t
|
||
|
|
(serve/servlet start
|
||
|
|
#:servlet-path "/"
|
||
|
|
#:listen-ip #f
|
||
|
|
#:command-line? #t
|
||
|
|
#:extra-files-paths (list (build-path "assets/")))
|