routes.scm (14645B)
1 (define-module (routes) 2 #:export (router)) 3 (use-modules (ice-9 match) 4 (rnrs bytevectors) 5 (srfi srfi-1) 6 (srfi srfi-26) 7 (sxml simple) 8 (web http) 9 (web request) 10 (web response) 11 (web uri) 12 (assets) 13 (cookie) 14 (db) 15 (style) 16 (pngenerator)) 17 18 (define user-cookie "_Host-user") 19 20 (define site-name "Metalympiáda") 21 (define round-name "Domáce kolo 2023/24") 22 (define deadline "letného slnovratu 2024") 23 (define after-deadline #t) 24 (define announcement (if after-deadline 25 "Čoskoro pribudnú nové zadania. Deadline bol do " 26 "Riešenia je možné posielať do ")) 27 28 (define current-round 2) 29 30 (define footer 31 `(footer "Stránka Metalympiády je slobodný softvér pod licenciou AGPL: " 32 (a (@ (href "/git/index.png")) "zdrojový kód"))) 33 34 (define (main-template body) 35 `((style ,style) 36 (meta (@ (name "viewport") (content "width=device-width, initial-scale=1"))) 37 (img (@ (class "meta") (src "#"))) 38 (main (header (a (@ (href "/")) ,logo) 39 (figure (pre (@ (class "textlogo") (role "img") 40 (aria-label "ASCII logo Metalympiády")) 41 ,text-logo))) 42 (nav (@ (id "mainav")) 43 (a (@ (class "navlink") (href "/pravidla.png")) "Pravidlá") 44 (a (@ (class "navlink") (href "/archiv.png")) "Archív") 45 (a (@ (class "navlink") (href "/vysledky.png")) "Výsledky")) 46 ,@body 47 ,footer))) 48 49 (define (title-template title body) 50 `((title ,title " | " ,site-name) 51 ,(main-template body))) 52 53 (define login-form 54 `(form (@ (class "login") (action "#") (method "POST")) 55 (label "Meno:" (input (@ (class "short") (name "name") (required)))) 56 (label "Heslo:" 57 (input (@ (class "short") (name "password") (type "password") (required)))) 58 (input (@ (class "button") (type "submit") (value "Prihlásiť"))) 59 (a (@ (href "/register.png")) "Registrovať"))) 60 61 (define (greeting user) 62 `((p "Prihlásený ako " 63 (strong ,user) 64 "! " 65 (a (@ (href "/logout.png")) "Odhlásiť sa")))) 66 67 (define* (text-page title text #:optional (user #f)) 68 (values 69 title 70 `(,(if user (greeting user) login-form) 71 (p (@ (class "text")) ,text)))) 72 73 (define* (problem-page #:optional (err #f) (user #f)) 74 (let ((answers (if user (select-answers-content user current-round) #f)) 75 (submit-available (and user (not after-deadline)))) 76 (values 77 "Zadania" 78 `(,(if err `(span (@ (class "error")) ,err) '()) 79 ,(if user (greeting user) `(,login-form (p "Pre odoslanie riešení sa prihláste"))) 80 (h1 ,round-name) 81 (p ,announcement (strong ,deadline)) 82 (form (@ (action "#") (method "POST")) 83 ,@(map (lambda (text index) 84 (let ((i (number->string (+ index 1)))) 85 `((p (@ (class "text")) 86 (span (@ (class "problem-num")) ,i ".") 87 ,text) 88 ,(if submit-available 89 `(input (@ (name ,i) 90 (class "block") 91 ,(if answers 92 `(value ,(list-ref answers 93 index)) 94 `(placeholder "Odpoveď " ,i)))) 95 '()) 96 (hr)))) 97 problems 98 (iota (length problems))) 99 ,(if submit-available 100 `(input (@ (class "button block") 101 (type "submit") 102 (value "Uložiť riešenia"))) 103 '())))))) 104 105 (define* (round-list title link #:optional (user #f)) 106 (values 107 title 108 `(,(if user (greeting user) login-form) 109 (h1 ,title) 110 ,@(map (lambda (i) `(p (a (@ (href ,link "/" ,i ".png")) "Kolo " ,i))) 111 (iota current-round))))) 112 113 (define* (archive-page a rnd #:optional (user #f)) 114 (let ((answers (if user (select-answers user rnd) #f)) 115 (title (string-append "Kolo " (number->string rnd)))) 116 (values 117 title 118 `(,(if user (greeting user) login-form) 119 (h1 ,title) 120 (form (@ (action "#") (method "POST")) 121 ,@(map (lambda (text solution index) 122 (let ((i (number->string (+ index 1)))) 123 `((p (@ (class "text")) 124 (span (@ (class "problem-num")) ,i ".") 125 ,text) 126 (p (@ (class "text")) 127 (strong (@ (class "start")) "Správna odpoveď:") 128 ,solution) 129 ,(if answers 130 (let* ((a (list-ref answers index)) 131 (v (vector-ref a 1))) 132 `((p (@ (class "text")) 133 (strong (@ (class "start")) 134 "Vaša odpoveď:") 135 ,(vector-ref a 0)) 136 (p (@ (class "text")) 137 (strong (@ (class "start " 138 ,(if (> v 0.5) 139 "good" 140 "bad"))) 141 "Hodnotenie:") 142 ,v))) 143 "") 144 (hr)))) 145 (archive-problems a) 146 (archive-solutions a) 147 (iota (length (archive-problems a))))))))) 148 149 (define (score-page rnd) 150 (let ((results (select-results rnd)) 151 (title (string-append "Výsledky kola " (number->string rnd)))) 152 (values 153 title 154 `((h1 ,title) 155 (table ,@(map (lambda (result i) 156 `(tr (td ,(+ i 1) ".") 157 (td ,(vector-ref result 0)) 158 (td ,(vector-ref result 1)))) 159 results 160 (iota (length results)))) 161 (p "Blahoželáme!"))))) 162 163 (define* (register-page #:optional (err #f)) 164 (values 165 "Registracia" 166 `(,(if err `(span (@ (class "error")) ,err) '()) 167 (form (@ (action "#") (method "POST")) 168 (label (@ (class "block")) 169 "Meno, pod ktorým chcete byť uvedení:" 170 (input (@ (name "name") (required)))) 171 (label (@ (class "block")) 172 "Heslo:" 173 (input (@ (name "password") (type "password") (required)))) 174 (label (@ (class "block")) 175 "Email (na potvrdenie a zaslanie výsledkov):" 176 (input (@ (name "email") (type "email") (required)))) 177 (label (@ (class "block small")) 178 "Súhlasím, aby moje odpovede na úlohy Metalympiády boli použité pri overovaní správnosti mojich riešení Metalympiády" 179 (input (@ (name "approval") (type "checkbox") (required)))) 180 (label (@ (class "block ghost")) 181 (input (@ (name "address")))) 182 (input (@ (class "button") (type "submit") (value "Registrovať"))))))) 183 184 (define (login-response user) 185 (values (build-response #:code 301 186 #:headers `((Location . "/index.png") 187 ,(set-cookie user-cookie 188 user 189 #:path "/" 190 #:secure #t 191 #:http-only #t))) 192 "")) 193 194 (define (logout-response) 195 (values (build-response #:code 301 196 #:headers `((Cache-Control . "no-cache") 197 (Location . "/index.png") 198 ,(delete-cookie user-cookie))) 199 "")) 200 201 (define (register-check fields) 202 (if (and (equal? (assoc-ref fields "approval") "on") 203 (equal? (assoc-ref fields "address") "")) 204 (register-handler fields) 205 (render (lambda () (register-page "Musíte súhlasiť!"))))) 206 207 (define (register-handler fields) 208 (let* ((maybe-user (insert-user (assoc-ref fields "name") 209 (assoc-ref fields "email") 210 (assoc-ref fields "password")))) 211 (if (car maybe-user) 212 (login-response (cadr maybe-user)) 213 (render (lambda () (register-page (cadr maybe-user))))))) 214 215 (define (login-handler fields) 216 (let* ((maybe-user (login-user (assoc-ref fields "name") 217 (assoc-ref fields "password")))) 218 (if (car maybe-user) 219 (login-response (cadr maybe-user)) 220 (render (lambda () (problem-page (cadr maybe-user))))))) 221 222 (define (submit-handler fields user round) 223 (let* ((answers (fold (lambda (i so-far) 224 (let ((a (assoc-ref fields (number->string (+ i 1))))) 225 (if (and so-far a) (append so-far (list a)) #f))) 226 '() 227 (iota (length problems)))) 228 (submitted (if (and answers (not after-deadline)) 229 (insert-answers answers user round) `(#f "Neplatné odpovede")))) 230 (render (lambda () 231 (problem-page (if (car submitted) #f (cadr submitted)) user))))) 232 233 (define* (render page #:optional (template title-template)) 234 (let ((rendered (call-with-output-string (cut 235 sxml->xml 236 (call-with-values page template) 237 <>)))) 238 (values (build-response 239 #:headers `((content-type text/html (charset . "utf-8")))) 240 (pngenerate rendered background-color foreground-color)))) 241 242 (define (redirect location) 243 (values (build-response #:code 301 #:headers `((Location . ,location))) "")) 244 245 (define (request-path-components request) 246 (split-and-decode-uri-path (uri-path (request-uri request)))) 247 248 (define (query->alist q) 249 (fold (lambda (pair so-far) 250 (match pair ((key value) (acons (uri-decode key) (uri-decode value) so-far)) 251 (_ so-far))) 252 '() 253 (map (cut string-split <> #\=) 254 (string-split (utf8->string q) (char-set #\& #\;))))) 255 256 (define (not-found) 257 (values (build-response #:code 404) "404")) 258 259 (define (correct-round-path rnd) 260 (let* ((split (string-split rnd #\.)) 261 (n (string->number (car split)))) 262 (if (and (eq? (length split) 2) 263 (equal? (cadr split) "png") 264 n 265 (< n current-round)) 266 n 267 #f))) 268 269 (define (router request body) 270 (let* ((method (request-method request)) 271 (path (request-path-components request)) 272 (fields (if body 273 (catch #t 274 (lambda () (query->alist body)) 275 (lambda () '())) 276 '())) 277 (cookie (assoc-ref (request-headers request) 'cookie)) 278 (encrypted-user (if cookie (assoc-ref cookie user-cookie) #f)) 279 (user (if encrypted-user (decrypt-user encrypted-user) #f))) 280 (match method 281 ('POST (match path 282 (("register.png") (register-check fields)) 283 (_ (if user 284 (submit-handler fields user current-round) 285 (login-handler fields))))) 286 ('GET (match path 287 (() (redirect "index.png")) 288 (("index.png") (render (lambda () (problem-page #f user)))) 289 (("pravidla.png") (render (lambda () (text-page "Pravidlá" 290 rules-text 291 user)))) 292 (("archiv.png") (render (lambda () (round-list "Archív" 293 "archiv" 294 user)))) 295 (("archiv" rnd) (let ((n (correct-round-path rnd))) 296 (if n 297 (render (lambda () 298 (archive-page (list-ref archive n) 299 n 300 user))) 301 (not-found)))) 302 (("vysledky.png") (render (lambda () (round-list "Výsledky" 303 "vysledky" 304 user)))) 305 (("vysledky" rnd) (let ((n (correct-round-path rnd))) 306 (if n 307 (render (lambda () 308 (score-page n))) 309 (not-found)))) 310 (("register.png") (render register-page)) 311 (("logout.png") (logout-response)) 312 (("git") (redirect "/git/index.png")) 313 (("git" . rest) (let ((s (hash-ref stagit-sources (string-join rest "/")))) 314 (if s 315 (render (lambda () s) main-template) 316 (not-found)))) 317 (("favicon.ico") (values (build-response #:code 410) "")) 318 (_ (not-found)))) 319 (_ (values (build-response #:code 402) "")))))