Add Mythic dynamic DNS service

1 files changed, 71 insertions, 0 deletions

diff --git a/tw/services/dns.scm b/tw/services/dns.scm
new file mode 100644
index 00000000..684fea5a
--- /dev/null
+++ b/tw/services/dns.scm
@@ -0,0 +1,71 @@
+(define-module (tw services dns)
+  #:use-module (gnu)
+  #:use-module ((gnu packages guile) #:select (guile-json-4))
+  #:use-module ((gnu packages tls) #:select (guile-gnutls))
+  #:use-module (gnu services)
+  #:use-module (gnu services configuration)
+  #:use-module (gnu services mcron)
+  #:use-module (guix gexp)
+  #:use-module ((guix records) #:select (match-record))
+  #:export (mythic-dynamic-dns-configuration
+            mythic-dynamic-dns-service-type))
+
+(define (string-or-gexp? thing)
+  (or (string? thing) (gexp? thing)))
+
+(define-configuration/no-serialization mythic-dynamic-dns-configuration
+  (schedule (string-or-gexp "*/15 * * * *") "The mcron schedule on which to
+update the machine's IP address.")
+  (credential-file (string "/etc/mythic-dns.scm") "The name of a file
+containing authentication parameters as two Lisp strings, the first being a
+username and the second being a password.  This file will be parsed using two
+Guile @code{read} calls.")
+  (host-name string "The host name to update with this device's public IP.")
+  (ipv4? (boolean #t) "Whether to update the specified host's A record.")
+  (ipv6? (boolean #t) "Whether to update the specified host's AAAA record."))
+
+(define (mythic-dynamic-dns-cronjob config api-host)
+  (match-record config <mythic-dynamic-dns-configuration>
+    (schedule host-name credential-file)
+    #~(job #$schedule
+           #$(program-file (string-append "dynamic-dns-" api-host "-command")
+               (with-extensions (list guile-json-4 guile-gnutls)  ; guile-gnutls needed by (web client)
+                 #~(begin
+                     (use-modules (srfi srfi-11)  ; `let*-values'
+                                  (ice-9 iconv)
+                                  (web client)
+                                  (web response)
+                                  (web uri)
+                                  (json))
+                     (let*-values
+                         (((update-url)
+                           (format #f "https://~a/dns/v2/dynamic/~a" #$api-host #$host-name))
+                          ((auth-body)
+                           (call-with-input-file #$credential-file
+                             (lambda (port)
+                               (string-append "username=" (uri-encode (read port))
+                                              "&password=" (uri-encode (read port))))))
+                          ((response body)
+                           (http-post update-url #:body auth-body #:decode-body? #t
+                                      #:headers '((content-type application/x-www-form-urlencoded))))
+                          ;; For some reason, the body is not decoded, even with `#:decode-body? #t'.
+                          ((decoded-body)
+                           (and body (bytevector->string body "utf-8"))))
+                       (if (= 200 (response-code response))
+                           (format (current-error-port) "Success: ~a\n"
+                                   (assoc-ref (json-string->scm decoded-body) "message"))
+                           (format (current-error-port) "Got error response ~a: ~a\n"
+                                   response decoded-body)))))))))
+
+(define (mythic-dynamic-dns-cronjobs config)
+  (match-record config <mythic-dynamic-dns-configuration>
+    (ipv4? ipv6?)
+    (append (if ipv4? (list (mythic-dynamic-dns-cronjob config "ipv4.api.mythic-beasts.com")) '())
+            (if ipv6? (list (mythic-dynamic-dns-cronjob config "ipv6.api.mythic-beasts.com")) '()))))
+
+(define mythic-dynamic-dns-service-type
+  (service-type
+   (name 'mythic-dynamic-dns)
+   (extensions
+    (list (service-extension mcron-service-type mythic-dynamic-dns-cronjobs)))
+   (description "Periodically update the host's DNS records with Mythic Beasts.")))