commit 6e399e6c4367800765045113efee16cc19c8dbc5 Author: haskal Date: Tue Sep 1 03:33:07 2020 -0400 initial commit diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..132a848 --- /dev/null +++ b/.gitignore @@ -0,0 +1,5 @@ +*.zo +*.dep +compiled/ +/config.rktd +/awoobot diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..3bf0c20 --- /dev/null +++ b/Makefile @@ -0,0 +1,7 @@ +.PHONY: all setup + +all: + raco exe -o awoobot awoobot.rkt + +setup: + cd astro && $(MAKE) setup diff --git a/README.md b/README.md new file mode 100644 index 0000000..607d61f --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# awoobot + +sharks diff --git a/astro/.gitignore b/astro/.gitignore new file mode 100644 index 0000000..c924677 --- /dev/null +++ b/astro/.gitignore @@ -0,0 +1,3 @@ +*.zo +*.dep +compiled/ diff --git a/astro/Makefile b/astro/Makefile new file mode 100644 index 0000000..0f31ef8 --- /dev/null +++ b/astro/Makefile @@ -0,0 +1,7 @@ +.PHONY: all setup + +all: + raco make *.rkt + +setup: + raco pkg install diff --git a/astro/README.md b/astro/README.md new file mode 100644 index 0000000..3610490 --- /dev/null +++ b/astro/README.md @@ -0,0 +1,3 @@ +# astro + +sharks diff --git a/astro/calendar.rkt b/astro/calendar.rkt new file mode 100644 index 0000000..8fff63f --- /dev/null +++ b/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)) + diff --git a/astro/info.rkt b/astro/info.rkt new file mode 100644 index 0000000..c8904f7 --- /dev/null +++ b/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"))') diff --git a/astro/lunar.rkt b/astro/lunar.rkt new file mode 100644 index 0000000..7a02675 --- /dev/null +++ b/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)) diff --git a/astro/main.rkt b/astro/main.rkt new file mode 100644 index 0000000..68685e9 --- /dev/null +++ b/astro/main.rkt @@ -0,0 +1,3 @@ +#lang racket/base + +;; empty for now diff --git a/awoobot.rkt b/awoobot.rkt new file mode 100755 index 0000000..93a97c9 --- /dev/null +++ b/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)) diff --git a/config.example.rktd b/config.example.rktd new file mode 100644 index 0000000..14cf799 --- /dev/null +++ b/config.example.rktd @@ -0,0 +1,3 @@ +#hash((instance . "myinstance.cool") + (token . "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA") + (char-limit . 500)) diff --git a/fedibot.rkt b/fedibot.rkt new file mode 100644 index 0000000..60b0d98 --- /dev/null +++ b/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))