diff options
Diffstat (limited to 'util.scm')
| -rw-r--r-- | util.scm | 153 |
1 files changed, 153 insertions, 0 deletions
diff --git a/util.scm b/util.scm new file mode 100644 index 0000000..495bcfd --- /dev/null +++ b/util.scm @@ -0,0 +1,153 @@ +;;; SPDX-FileCopyrightText: 2026 Matthew Fennell <matthew@fennell.dev> +;;; +;;; SPDX-License-Identifier: AGPL-3.0-or-later + +;;; General + +(define (cartesian-product . lists) + (fold-right + (lambda (xs ys) + (append-map + (lambda (x) (map (lambda (y) (cons x y)) ys)) xs)) '(()) lists)) + +(define* (api-request #:key method path (query #f) (request #f) (transformer identity) (token #f)) + (let*-values + (((record-name) + (delay + (string-filter + (lambda (c) (or (char-alphabetic? c) (eq? c #\-))) + (symbol->string (record-type-name (record-type-descriptor request)))))) + ((json) + (delay + (local-eval + `(,(string->symbol + (string-append (force record-name) "->json")) request) + (the-environment)))) + ((base-headers) '((content-type . (application/json)) + (origin . "https://myaccount.better.org.uk"))) + ((auth-header) (delay `(Authorization . ,(string-append "Bearer " token)))) + ((request-headers) (if token (cons (force auth-header) base-headers) base-headers)) + ((request-body) (if request (force json) #f)) + ((host) "better-admin.org.uk") + ((response-header response-body-utf8) + (http-request + (build-uri + 'https + #:host host + #:path path + #:query query) + #:method method + #:body request-body + #:headers request-headers)) + ((response-body) (utf8->string response-body-utf8)) + ((response-error-message) (delay (error-response-message (json->error-response response-body)))) + ((exception) + (make-exception (make-external-error) + (make-exception-with-origin request-body) + (make-exception-with-irritants + `(,response-header ,response-body))))) + (log-msg 'REQUEST method " " "https://" host path "/" (or query "")) + (log-msg 'DEBUG "Headers: " response-header) + (log-msg 'SENSITIVE "Response: " response-body) + (case (response-code response-header) + ((200) (let ((result (transformer response-body))) + (log-msg 'SENSITIVE "Result: " result) + result)) + ((422) (cond ((string-contains (force response-error-message) "The date should be within the valid days") #f) + ((string-contains (force response-error-message) "You have already booked a session for this time") #t) + (else (raise-exception exception)))) + (else (raise-exception exception))))) + +(define fake-score + (let* ((fake-date (make-date 0 0 0 0 0 0 0 0)) + (fake-booking (make-booking 'fake-venue 'fake-activity fake-date fake-date))) + `(,fake-booking ,(-(inf))))) + +;;; Dates + +(define dates #(sun mon tue wed thu fri sat)) + +(define (date->day-name date) + ((compose week-day->day-name date-week-day) date)) + +(define (week-day->day-name index) + (vector-ref dates index)) + +(define (day-name->week-day name) + (list-index (lambda (d) (eq? d name)) (vector->list dates))) + +(define (date-date date) + (make-date 0 0 0 0 + (date-day date) + (date-month date) + (date-year date) + (date-zone-offset date))) + +(define (date-time date) + (make-date 0 0 + (date-minute date) + (date-hour date) + 0 0 0 0)) + +(define (this day-name) + (log-msg 'DEBUG "Calculating next " day-name) + (let* ((date-offset (if (> (date-hour (current-date)) 22) 1 0)) + (current-date (date+ (current-date) date-offset)) + (current-week-day (date-week-day current-date)) + (target-week-day (day-name->week-day day-name)) + (days-ahead (mod (- target-week-day current-week-day) 7)) + (target-date (date+ current-date days-ahead))) + (log-msg 'DEBUG "Including 10pm offset, current date is " (date->api-string current-date) ", which is " (week-day->day-name current-week-day)) + (log-msg 'DEBUG "Target date " day-name " is " days-ahead " days ahead of " (week-day->day-name current-week-day)) + (log-msg 'DEBUG "Therefore " (date->api-string current-date) " + " days-ahead " days = " ((compose date->api-string date-date) target-date)) + (date-date target-date))) + +(define (date->api-string date) + (date->string date "~1")) + +(define (time->api-string date) + (date->string date "~H:~M")) + +(define (api-string->date date-str) + (string->date date-str "~Y-~m-~d")) + +(define (api-string->time time-str) + (string->date (string-append "1970-01-01 " time-str) "~Y-~m-~d ~H:~M")) + +(define (date<? date1 date2) + (time<? (date->time-utc date1) (date->time-utc date2))) + +(define (date<=? date1 date2) + (time<=? (date->time-utc date1) (date->time-utc date2))) + +(define (date>=? date1 date2) + (time>=? (date->time-utc date1) (date->time-utc date2))) + +(define (date+ date days) + (let ((duration-to-add (make-time time-duration 0 (* days 24 60 60))) + (date-time (date->time-utc (date-date date)))) + ((compose date-date time-utc->date) (add-duration date-time duration-to-add)))) + +(define (score>? score1 score2) + (> (second score1) (second score2))) + +(define (max-score score1 score2) + (if (score>? score1 score2) score1 score2)) + +;;; Scorer helpers + +(define (between-hours? booking between-start-str between-end-str) + (let ((booking-start ((compose date-time booking-start) booking)) + (booking-end ((compose date-time booking-end) booking)) + (between-start ((compose date-time api-string->time) between-start-str)) + (between-end ((compose date-time api-string->time) between-end-str))) + (and (date>=? booking-start between-start) (date<=? booking-end between-end)))) + +(define (booking-end<? booking1 booking2) + (date<? (booking-end booking1) (booking-end booking2))) + +(define (badminton-60min? booking) + (eq? (booking-activity booking) 'badminton-60min)) + +(define (sat? booking) + (eq? ((compose date->day-name booking-start) booking) 'sat)) |