blob: 495bcfd2fe92cc010d899e2024a1cce578cae131 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
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))
|
