initial commit

.gitignore

@@ -0,0 +1,5 @@
+*.zo
+*.dep
+compiled/
+/config.rktd
+/awoobot

Makefile

@@ -0,0 +1,7 @@
+.PHONY: all setup
+
+all:
+	raco exe -o awoobot awoobot.rkt
+
+setup:
+	cd astro && $(MAKE) setup

README.md

@@ -0,0 +1,3 @@
+# awoobot
+
+sharks

astro/.gitignore

@@ -0,0 +1,3 @@
+*.zo
+*.dep
+compiled/

astro/Makefile

@@ -0,0 +1,7 @@
+.PHONY: all setup
+
+all:
+	raco make *.rkt
+
+setup:
+	raco pkg install

astro/README.md

@@ -0,0 +1,3 @@
+# astro
+
+sharks

astro/calendar.rkt

@@ -0,0 +1,72 @@
+#lang racket/base
+
+(require racket/date)
+
+(provide date-values->jd
+         jd->date-values
+         dynamical-delta-t)
+
+;; meeus, ch 7
+
+;; counting from 1
+(define (date-values->jd year month day)
+  (define julian? (or (< year 1582)
+                      (and (= year 1582) (< month 10))
+                      (and (= year 1582) (= month 10) (<= day 4))))
+
+  ;; there's a range of days that doesn't exist due to the julian/gregorian transition
+  (when (and (= year 1582) (= month 10) (or (> day 4) (< day 15)))
+    (error "invalid date provided"))
+
+  (define-values [year* month*]
+    (if (> month 2)
+      (values year month)
+      (values (sub1 year) (+ 12 month))))
+  (define a (quotient year* 100))
+  (define b (if julian? 0 (+ 2 (- a) (quotient a 4))))
+  (+ (floor (* 365.25 (+ year* 4716))) (floor (* 30.6001 (add1 month*)))
+     day b -1524.5))
+
+;; (values year month day)
+(define (jd->date-values jd)
+  (define-values [Z F]
+    (let* ([jd+ (+ 0.5 jd)]
+           [jdq (floor jd+)])
+      (values jdq (- jd+ jdq))))
+  (define A (if (< Z 2299161)
+              Z
+              (let ([α (floor (/ (- Z 1867216.25) 36524.25))])
+                (+ Z 1 α (- (floor (/ α 4)))))))
+  (define B (+ A 1524))
+  (define C (floor (/ (- B 122.1) 365.25)))
+  (define D (floor (* C 365.25)))
+  (define E (floor (/ (- B D) 30.6001)))
+
+  (define day (- B D (floor (* 30.6001 E)) (- F)))
+  (define month (if (< E 14) (sub1 E) (- E 13)))
+  (define year (if (> month 2) (- C 4716) (- C 4715)))
+  (values (inexact->exact year) (inexact->exact month) day))
+
+(define (dynamical-delta-t year)
+  (define t (/ (- year 2000) 100.))
+  (+ 102. (* 102. t) (* 25.4 t t)))
+
+(module+ test
+  (require rackunit)
+  ;; TODO add tests. page 62
+  ;; 7.a
+  (check-= (date-values->jd 1957 10 4.81) 2436116.31 0.000001)
+  ;; 7.b
+  (check-= (date-values->jd 333 1 27.5) 1842713.0 0.000001)
+  ;; 7.c
+  (define-values [y1 m1 d1] (jd->date-values 2436116.31))
+  (check-equal? y1 1957)
+  (check-equal? m1 10)
+  (check-= d1 4.81 0.000001)
+  ;; custom
+  (define jd2 (date-values->jd 2020 9 2.2236))
+  (define-values [y2 m2 d2] (jd->date-values jd2))
+  (check-equal? y2 2020)
+  (check-equal? m2 9)
+  (check-= d2 2.2236 0.000001))
+

astro/info.rkt

@@ -0,0 +1,7 @@
+#lang info
+
+(define version "0.0.1")
+(define collection "astro")
+(define deps '("base"))
+(define test-omit-paths '("info.rkt"))
+; (define scribblings '(("astro.scrbl"))')

astro/lunar.rkt

@@ -0,0 +1,260 @@
+#lang racket/base
+
+(require racket/math racket/vector racket/match
+         "./calendar.rkt")
+
+(provide lunar-next-phase)
+
+;; meeus, ch 47
+
+(define (lunar-mean-phase+ k T)
+  (+ 2451550.09766
+     (* 29.530588861 k)
+     (* 0.00015437 T T)
+     (- (* 0.000000150 T T T))
+     (* 0.00000000073 T T T T)))
+
+;; phase must correspond to the decimal part of k
+;; phase is one of 'new 'first 'full 'last
+(define (lunar-precise-phase+ k phase)
+  (define T (/ k 1236.85))
+  (define lmm (lunar-mean-phase+ k T))
+
+  ;; corrections
+  (define E (- 1 (* 0.002516 T) (* 0.0000074 T T)))
+  (define (d->r val)
+    (degrees->radians val))
+
+  (define M (d->r (+ 2.5534 (* 29.10535670 k)
+                     (* -0.0000014 T T)
+                     (* -0.00000011 T T T))))
+  (define M* (d->r (+ 201.5643 (* 385.81693528 k)
+                      (* 0.0107582 T T)
+                      (* 0.00001238 T T T)
+                      (* -0.000000058 T T T T))))
+  (define F (d->r (+ 160.7108 (* 390.67050284 k)
+                     (* -0.0016118 T T)
+                     (* -0.00000227 T T T)
+                     (* 0.000000011 T T T T))))
+  (define Ω (d->r (+ 124.7746 (* -1.56375588 k)
+                     (* 0.0020672 T T)
+                     (* 0.00000215 T T T))))
+
+  (define A
+    (vector-map
+      d->r
+      (vector (+ 299.77 (*  0.107408 k) (* -0.009173 T T))
+              (+ 251.88 (*  0.016321 k))
+              (+ 251.83 (* 26.651886 k))
+              (+ 349.42 (* 36.412478 k))
+              (+  84.66 (* 18.206239 k))
+              (+ 141.74 (* 53.303771 k))
+              (+ 207.14 (*  2.453732 k))
+              (+ 154.84 (*  7.306860 k))
+              (+  34.52 (* 27.261239 k))
+              (+ 207.19 (*  0.121824 k))
+              (+ 291.34 (*  1.844379 k))
+              (+ 161.72 (* 24.198154 k))
+              (+ 239.56 (* 25.513099 k))
+              (+ 331.55 (*  3.592518 k)))))
+
+  (define periodic-multipliers
+    (match phase
+      ['new
+       (vector    -0.40720
+               (* +0.17241 E)
+                  +0.01608
+                  +0.01039
+               (* +0.00739 E)
+               (* -0.00514 E)
+               (* +0.00208 E E)
+                  -0.00111
+                  -0.00057
+               (* +0.00056 E)
+                  -0.00042
+               (* +0.00042 E)
+               (* +0.00038 E)
+               (* -0.00024 E)
+                  -0.00017
+                  -0.00007
+                  +0.00004
+                  +0.00004
+                  +0.00003
+                  +0.00003
+                  -0.00003
+                  +0.00003
+                  -0.00002
+                  -0.00002
+                  +0.00002)]
+      ['full
+       (vector    -0.40614
+               (* +0.17302 E)
+                  +0.01614
+                  +0.01043
+               (* +0.00734 E)
+               (* -0.00515 E)
+               (* +0.00209 E E)
+                  -0.00111
+                  -0.00057
+               (* +0.00056 E)
+                  -0.00042
+               (* +0.00042 E)
+               (* +0.00038 E)
+               (* -0.00024 E)
+                  -0.00017
+                  -0.00007
+                  +0.00004
+                  +0.00004
+                  +0.00003
+                  +0.00003
+                  -0.00003
+                  +0.00003
+                  -0.00002
+                  -0.00002
+                  +0.00002)]
+      [(or 'first 'last)
+       (vector    -0.62801
+               (* +0.17172 E)
+               (* -0.01182 E)
+                  +0.00862
+                  +0.00804
+               (* +0.00454 E)
+               (* +0.00204 E E)
+                  -0.00180
+                  -0.00070
+                  -0.00040
+               (* -0.00034 E)
+               (* +0.00032 E)
+               (* +0.00032 E)
+               (* -0.00028 E E)
+               (* +0.00027 E)
+                  -0.00017
+                  -0.00005
+                  +0.00004
+                  -0.00004
+                  +0.00004
+                  +0.00004
+                  +0.00004
+                  +0.00002
+                  +0.00002
+                  -0.00002)]))
+  (define periodic-sine-terms
+    (match phase
+      [(or 'new 'full)
+       (vector    M*
+                  M
+               (* M* 2)
+               (* F 2)
+               (- M* M)
+               (+ M* M)
+               (* M 2)
+               (- M* (* 2 F))
+               (+ M* (* 2 F))
+               (+ (* 2 M*) M)
+               (* 3 M*)
+               (+ M (* 2 F))
+               (- M (* 2 F))
+               (- (* 2 M*) M)
+                  Ω
+               (+ M* (* 2 M))
+               (- (* 2 M*) (* 2 F))
+               (* 3 M)
+               (+ M* M (* -2 F))
+               (+ (* 2 M*) (* 2 F))
+               (+ M* M (* 2 F))
+               (+ M* (- M) (* 2 F))
+               (- M* M (* 2 F))
+               (+ (* 3 M*) M)
+               (* 4 M*))]
+      [(or 'first 'last)
+       (vector    M*
+                  M
+               (+ M* M)
+               (* 2 M*)
+               (* 2 F)
+               (- M* M)
+               (* 2 M)
+               (- M* (* 2 F))
+               (+ M* (* 2 F))
+               (* 3 M*)
+               (- (* 2 M*) M)
+               (+ M (* 2 F))
+               (- M (* 2 F))
+               (+ M* (* 2 M))
+               (+ (* 2 M*) M)
+               Ω
+               (- M* M (* 2 F))
+               (+ (* 2 M*) (* 2 F))
+               (+ M* M (* 2 F))
+               (- M* (* 2 M))
+               (+ M* M (* -2 F))
+               (* 3 M)
+               (- (* 2 M*) (* 2 F))
+               (+ M* (- M) (* 2 F))
+               (+ (* 3 M*) M))]))
+
+  (define periodic-correction
+    (for/sum ([multiplier (in-vector periodic-multipliers)]
+              [sine-term (in-vector periodic-sine-terms)])
+      (* multiplier (sin sine-term))))
+
+  (define W (+ 0.00306
+               (* -0.00038 E (cos M))
+               (*  0.00026 (cos M*))
+               (* -0.00002 (cos (- M* M)))
+               (*  0.00002 (cos (+ M* M)))
+               (*  0.00002 (cos (* 2 F)))))
+  (define phase-correction
+    (match phase
+      ['first W]
+      ['last (- W)]
+      [(or 'new 'full) 0]))
+
+  (define additional-multipliers
+    (vector 0.000325
+            0.000165
+            0.000164
+            0.000126
+            0.000110
+            0.000062
+            0.000060
+            0.000056
+            0.000047
+            0.000042
+            0.000040
+            0.000037
+            0.000035
+            0.000023))
+  (define additional-correction
+    (for/sum ([Ai (in-vector A)]
+              [multipler (in-vector additional-multipliers)])
+      (* multipler (sin Ai))))
+
+  ; (define r->d radians->degrees)
+  ; (printf "lmm ~a E ~a M ~a M* ~a F ~a Ω ~a\n" lmm E (r->d M) (r->d M*) (r->d F) (r->d Ω))
+  ; (printf "C1 ~a C2 ~a C3 ~a\n" periodic-correction phase-correction additional-correction)
+
+  (+ lmm periodic-correction phase-correction additional-correction))
+
+;; 1-indexed again
+(define (lunar-next-phase jd phase)
+  (define fraction
+    (match phase
+      ['new   0.00]
+      ['first 0.25]
+      ['full  0.50]
+      ['last  0.75]))
+
+  (define seekb -3)
+  (define seekf 10)
+
+  (define-values [year month day] (jd->date-values jd))
+  (define k~ (let ([k~ (* (- (+ year (/ (sub1 month) 12)) 2000) 12.3685)])
+               (+ (floor k~) seekb fraction)))
+
+  (define trials (for/vector #:length 10 ([offset (in-range seekb seekf)])
+                   (lunar-precise-phase+ (+ k~ offset) phase)))
+
+  (for/first ([x (in-vector trials)]
+              #:when (>= x jd))
+             x))

astro/main.rkt

@@ -0,0 +1,3 @@
+#lang racket/base
+
+;; empty for now

awoobot.rkt

@@ -0,0 +1,75 @@
+#!/usr/bin/env racket
+
+#lang racket
+
+(require astro/calendar astro/lunar
+         racket/date
+         "fedibot.rkt")
+
+(define (current-date/utc)
+  (seconds->date (* 0.001 (current-inexact-milliseconds)) #f))
+
+(define (date->jd dt)
+  (match-define (date ss mm hh d m y _ _ _ _) dt)
+  (define d+ (+ d (/ hh 24) (/ mm 1440) (/ ss 86400)))
+  (date-values->jd y m d+))
+
+(define (jd->date-values* jd)
+  (define-values [y m d] (jd->date-values jd))
+  (define dq (floor d))
+  (define df (- d dq))
+  (define h (* df 24))
+  (define hq (floor h))
+  (define hf (- h hq))
+  (define mm (* hf 60))
+  (define mmq (floor mm))
+  (define mmf (- mm mmq))
+  (define ssq (floor (* mmf 60)))
+  (values y m (inexact->exact dq) (inexact->exact hq) (inexact->exact mmq) (inexact->exact ssq)))
+
+(define (do-awoo)
+  (define (str-rpt-random str)
+    (apply string-append (vector->list (make-vector (random 1 10) str))))
+
+  (define toot (make-toot (string-append "AWOO" (str-rpt-random "O") (str-rpt-random "!"))))
+  (send-toot/retry-on-err toot)
+  (void))
+
+(define (run-bot)
+  (define now (current-date/utc))
+  (define now-jd (date->jd now))
+  (define DT (dynamical-delta-t (date-year now)))
+  (define fullmoon-jd (- (lunar-next-phase now-jd 'full)
+                         (/ DT 86400)))
+  (displayln now-jd)
+  (displayln fullmoon-jd)
+  (define-values [y m d hh mm ss] (jd->date-values* fullmoon-jd))
+
+  (if (< (- fullmoon-jd now-jd) (/ 60 86400))
+    (begin
+      (displayln "preparing to awoo")
+      (sleep (inexact->exact (floor (* 86400 (- fullmoon-jd now-jd)))))
+      (do-awoo)
+      (sleep 5))
+    (displayln "not time to awoo yet")))
+
+(define (schedule-next)
+  (define now (current-date/utc))
+  (define now-jd (date->jd now))
+  (define DT (dynamical-delta-t (date-year now)))
+  (define fullmoon-jd (- (lunar-next-phase now-jd 'full)
+                         (/ DT 86400)))
+  (define-values [y m d hh mm ss] (jd->date-values* (- fullmoon-jd (/ 30 86400))))
+  (printf "schedule wakeup for: ~a ~a ~a ~a ~a ~a\n" y m d hh mm ss)
+
+  (displayln "invoking systemd")
+  (system* "/usr/bin/env" "systemd-run" "--user" "--same-dir"
+           (format "--on-calendar=~a-~a-~a ~a:~a:~a UTC" y m d hh mm ss)
+           (path->string (path->complete-path (find-system-path 'run-file)))))
+
+
+(parameterize ([current-config (config-from-file "config.rktd")])
+  (run-bot)
+  (schedule-next)
+
+  (void))

config.example.rktd

@@ -0,0 +1,3 @@
+#hash((instance   . "myinstance.cool")
+      (token      . "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA")
+      (char-limit . 500))

fedibot.rkt

@@ -0,0 +1,121 @@
+#lang racket
+
+(require racket/async-channel
+         json
+         net/url
+         net/uri-codec
+         ; net/rfc6455
+         uuid)
+
+(provide [struct-out app-config]
+         config-from-file
+         current-config
+         make-toot
+         send-toot
+         send-toot/retry-on-err
+         verify-creds
+         ; stream-user
+         fetch-toot)
+
+;; Bot configuration
+(struct app-config [instance token char-limit] #:transparent)
+
+(define (config-from-file filename)
+  (define conf (with-input-from-file filename read))
+  ;; this could be a macro
+  (app-config
+    (hash-ref conf 'instance)
+    (hash-ref conf 'token)
+    (hash-ref conf 'char-limit 500)))
+
+;; Represents the current masto config
+(define current-config (make-parameter #f))
+
+;; Utils
+(define (make-api-url path #:ws? [ws? #f] #:query [query '()])
+  (url (if ws? "wss" "https")
+                 #f (app-config-instance (current-config))
+                 #f #t
+                 `(,(path/param "api" '())
+                   ,(path/param "v1" '())
+                   ,@(map (lambda (x) (path/param x '())) path))
+                 query #f))
+
+(define (make-header k v)
+  (string-append k ": " v))
+
+(define (get-authorization)
+  (string-append "Bearer " (app-config-token (current-config)))) 
+
+(define (guard-config)
+  (unless (app-config? (current-config))
+    (error "current-config is not set up")))
+
+;; Creates a toot
+(define (make-toot status #:cw [cw #f] #:reply-to [reply-to #f]
+                   #:sensitive [sensitive #f] #:language [lang #f]
+                   #:visibility [visibility #f])
+  (for/fold ([out '()])
+            ([name '(status in_reply_to_id sensitive spoiler_text language visibility)]
+             [value (list status reply-to sensitive cw lang visibility)])
+    (cond [(false? value) out]
+          [else (cons (cons name value) out)])))
+
+;; Sends a toot
+(define (send-toot toot [idem-key (uuid-string)])
+  (guard-config)
+  (define-values (status headers rsp)
+    (http-sendrecv/url (make-api-url '("statuses"))
+                       #:method "POST"
+                       #:headers (list
+                                  (make-header "Idempotency-Key" idem-key)
+                                  (make-header "Authorization" (get-authorization))
+                                  (make-header "Content-Type" "application/x-www-form-urlencoded"))
+                       #:data (alist->form-urlencoded toot)))
+  (string->jsexpr (port->string rsp)))
+
+(define MAX-TRIES 10)
+(define SLEEP-CAP 60)
+
+(define (send-toot/retry-on-err toot [idem-key (uuid-string)] [tries 0])
+  (guard-config)
+  (define (handle-err ex)
+    (displayln "toot failed")
+    (displayln ex)
+    (if (>= tries MAX-TRIES)
+      (raise ex)
+      (begin
+        (sleep (min SLEEP-CAP (* tries 5)))
+        (send-toot/retry-on-err toot idem-key (add1 tries)))))
+  (with-handlers ([exn? handle-err])
+    (send-toot toot idem-key)))
+
+(define (verify-creds)
+  (guard-config)
+  (define-values (status headers rsp)
+    (http-sendrecv/url (make-api-url '("accounts" "verify_credentials"))
+                       #:headers (list (make-header "Authorization" (get-authorization)))))
+  (string->jsexpr (port->string rsp)))
+
+(define (fetch-toot toot-id)
+  (guard-config)
+  (define-values (status headers rsp)
+    (http-sendrecv/url (make-api-url (list "statuses" toot-id))
+                       #:headers (list (make-header "Authorization" (get-authorization)))))
+  (string->jsexpr (port->string rsp)))
+
+;; Stream incoming toots
+; (define (stream-user chan)
+;   (define query (list (cons 'access_token (app-config-token (current-config)))
+;                       (cons 'stream "user")))
+;   (define ws (ws-connect (make-api-url '("streaming") #:ws? #t #:query query)))
+;   (define (stream-forever chan)
+;     (let ([msg (ws-recv ws)])
+;       (cond [(equal? msg eof) (void)]
+;             [else
+;              (define msg-data (string->jsexpr msg)
+;              (async-channel-put chan (list (hash-ref msg-data 'event)
+;                                            (hash-ref msg-data 'payload)))
+;              (stream-forever chan)])))
+;   (stream-forever chan)
+;   (ws-close! ws))