Initial commit

1 files changed, 185 insertions, 0 deletions

diff --git a/shuttlebot.scm b/shuttlebot.scm
new file mode 100755
index 0000000..3672ae2
--- /dev/null
+++ b/shuttlebot.scm
@@ -0,0 +1,185 @@
+#!/usr/bin/guile \
+-e main -s
+!#
+
+;;; SPDX-FileCopyrightText: 2026 Matthew Fennell <matthew@fennell.dev>
+;;;
+;;; SPDX-License-Identifier: AGPL-3.0-or-later
+
+(use-modules (ice-9 exceptions)
+             (ice-9 local-eval)
+             (ice-9 match)
+             (ice-9 receive)
+             (ice-9 string-fun)
+             (ice-9 threads)
+             (json)
+             (logging logger)
+             (logging port-log)
+             (oop goops)
+             ((rnrs base) #:select (mod))
+             (rnrs bytevectors)
+             (srfi srfi-1)
+             (srfi srfi-9 gnu)
+             (srfi srfi-11)
+             (srfi srfi-19)
+             (srfi srfi-26)
+             (srfi srfi-45)
+             (web client)
+             (web http)
+             (web response)
+             (web uri))
+
+(include "records.scm")
+(include "config.scm")
+
+(define logger (make <logger>))
+(define handler (make <port-log> #:port (current-output-port)))
+(add-handler! logger handler)
+(disable-log-level! logger 'DEBUG)
+(disable-log-level! logger 'SENSITIVE)
+(set-default-logger! logger)
+
+(define (login login-request)
+  (log-msg 'INFO "Logging in as " (login-request-username login-request))
+  (api-request #:method 'POST
+               #:path "/api/auth/customer/login"
+               #:request login-request
+               #:transformer (lambda (b)
+                               (login-response-token
+                                (json->login-response b)))))
+
+(define* (times #:key
+                (venues default-venues)
+                (activities default-activities)
+                (dates default-dates)
+                (token #f))
+  (let*
+      ((venues (map symbol->string venues))
+       (activities (map symbol->string activities))
+       (dates (map this dates))
+       (dates (filter (lambda (d) (not (equal? d (date-date (current-date))))) dates))
+       (dates (map date->api-string dates))
+       (permutations (cartesian-product venues activities dates))
+       (positive-spaces? (lambda (t) ((compose positive? time-data-spaces) t)))
+       (requests
+	(map
+	 (lambda (permutation)
+	   (match permutation
+             ((venue activity date)
+              `(api-request #:method 'GET
+			    #:path ,(string-append
+                                     "/api/activities/venue/" venue
+                                     "/activity/" activity
+                                     "/times")
+			    #:query ,(string-append "date=" date)
+			    #:transformer ,(lambda (b) (map time-data->booking (filter positive-spaces? ((compose time-response-data json->time-response) b))))
+			    #:token ,token))))
+	 permutations))
+       (all-times (apply append (filter identity (par-map (lambda (r) (local-eval r (the-environment))) requests)))))
+    all-times))
+
+(define* (scored bookings #:key (scorer default-scorer))
+  (let*
+      ((bookings (sort bookings booking-end<?))
+       (scores (map scorer bookings))
+       (scored (zip bookings scores))
+       (scored (stable-sort scored (lambda (a b) (and (< (second a) (second b))))))
+       (scored (reverse scored)))
+    scored))
+
+(define* (bookings #:key (venues default-venues)
+                   (activities default-activities)
+                   (dates default-dates)
+                   token)
+  (let ((all-bookings (api-request #:method 'GET
+                                   #:path "/api/my-account/bookings"
+                                   #:query "filter=future"
+                                   #:transformer (lambda (d)
+                                                   (map bookings-response-data->booking
+                                                        ((compose bookings-response-data json->bookings-response) d)))
+                                   #:token token)))
+    (filter (lambda (b)
+              (and (any (cute eq? <> (booking-venue b)) venues)
+                   (any (cute eq? <> (booking-activity b)) activities)
+                   (any (cute eq? <> ((compose date->day-name booking-start) b)) dates)))
+            all-bookings)))
+
+(define* (book booking #:key (checkout #t) token)
+  (define* (get-slot booking #:key (token #f))
+    (log-msg 'INFO "Finding a free slot for booking " booking)
+    (let* ((venue ((compose symbol->string booking-venue) booking))
+           (activity ((compose symbol->string booking-activity) booking))
+           (date ((compose date->api-string booking-start) booking))
+           (start ((compose time->api-string booking-start) booking))
+           (end ((compose time->api-string booking-end) booking))
+           (path (string-append "/api/activities/venue/" venue
+                                "/activity/" activity
+                                "/slots"))
+           (query (string-append "date=" date
+                                 "&start_time=" start
+                                 "&end_time=" end))
+           (transformer (lambda (b)
+                          (car (filter (compose positive? slot-spaces)
+                                       ((compose slots-response-data json->slots-response) b))))))
+      (api-request #:method 'GET
+                   #:path path
+                   #:query query
+                   #:transformer transformer
+                   #:token token)))
+  (define* (add slot #:key token)
+    (let
+	((request (make-add-request (list (make-add-item (slot-id slot)
+							 (slot-type slot))))))
+      (api-request #:method 'POST
+                   #:path "/api/activities/cart/add"
+                   #:request request
+                   #:token token)
+      #t))
+  (define* (get-cart #:key token)
+    (api-request #:method 'GET
+                 #:path "/api/activities/cart"
+                 #:transformer (compose cart-response-data json->cart-response)
+                 #:token token))
+  (define* (apply-credit cart #:key token)
+    (let
+	((request (make-apply-credits-request "activity-booking" (list (make-credits-to-reserve (cart-total cart) "general")) 'null)))
+      (api-request #:method 'POST
+                   #:path "/api/credits/apply"
+                   #:request request
+                   #:token token)
+      #t))
+  (define* (complete cart #:key token)
+    (let*
+	((payment (make-payment "credit" (cart-total cart) '()))
+	 (request (make-complete-request #() `(,payment) 'null "activity-booking" #(1) (cart-item-hash cart))))
+      (api-request #:method 'POST
+                   #:path "/api/checkout/complete"
+                   #:request request
+                   #:token token)
+      #t))
+
+  (define slot (get-slot booking #:token token))
+  (add slot #:token token)
+  (when checkout
+    (let ((cart (get-cart #:token token)))
+      (apply-credit cart #:token token)
+      (complete cart #:token token))))
+
+(define* (book-best #:key (venues default-venues)
+                    (activities default-activities)
+                    (dates default-dates)
+                    (checkout default-checkout)
+                    (user default-user))
+  (let* ((token (login user))
+         (existing (scored (bookings #:venues venues #:activities activities #:dates dates #:token token)))
+         (best-existing (reduce max-score fake-score existing))
+         (new (scored (times #:venues venues #:activities activities #:dates dates #:token token)))
+         (best-new (reduce max-score fake-score new)))
+    (log-msg 'INFO "Best new booking: " (first best-new) " with score " (second best-new))
+    (log-msg 'INFO "Best existing booking: " (first best-existing) " with score " (second best-existing))
+    (when (score>? best-new best-existing)
+      (log-msg 'INFO "Booking " (first best-new))
+      (book (first best-new) #:checkout checkout #:token token))
+    (log-msg 'INFO "Done")))
+
+(define (main args) (book-best))