adding bonerbonerboner vocab

2023-06-16 21:37:31 -04:00 · 2023-06-16 21:37:31 -04:00 · 0179a4ce08
parent e3e24c5c4b
commit 0179a4ce08
5 changed files with 126 additions and 0 deletions
--- a/bonerbonerboner/actions/actions.factor
+++ b/bonerbonerboner/actions/actions.factor
@ -0,0 +1,41 @@
+USING: kernel furnace.actions sequences validators accessors html.forms http.server.responses http.server.dispatchers formatting ;
+USING: bonerbonerboner.dns ;
+
+IN: bonerbonerboner.actions
+
+TUPLE: bbb-dispatcher < dispatcher ;
+
+: v-valid-subdomain ( str -- subdomain )
+    dup get-subdomains member? [ "not a valid subdomain" throw ] unless ;
+
+: validate-subdomain ( -- )
+    {
+        { "name" [ v-required v-valid-subdomain ] }
+    } validate-params ;
+
+: <subdomain-action> ( -- action )
+    <page-action>
+    [
+        validate-subdomain
+        "name" value "subdomain" set-value
+    ] >>init
+    { bbb-dispatcher "subdomains" } >>template ;
+
+: <404-subdomain-action> ( -- action )
+    <page-action>
+    [ "_404" "subdomain" set-value ] >>init
+    { bbb-dispatcher "subdomains" } >>template ;
+
+: <heartbeat-action> ( -- action )
+    <action> [ "bonerbonerboner" <text-content> ] >>display ;
+
+TUPLE: subdomain-link subdomain url ;
+
+: <meta-action> ( -- action )
+    <page-action>
+    [
+        get-subdomains
+        [ dup "name" "https://%s.bonerbonerboner.com" sprintf subdomain-link boa ]
+        map "subdomains" set-value
+    ] >>init
+    { bbb-dispatcher "meta" } >>template ;
--- a/bonerbonerboner/actions/subdomains.xml
+++ b/bonerbonerboner/actions/subdomains.xml
@ -0,0 +1,14 @@
+<?xml version='1.0'?>
+<!DOCTYPE html>
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+  <html class="@subdomain" lang="en">
+    <head>
+      <title>boners</title>
+      <meta name="viewport"
+      content="width=device-width, initial-scale=1" />
+      <link rel="stylesheet" type="text/css"
+      href="https://static.bonerbonerboner.com/css/bbb.css" />
+    </head>
+    <body />
+  </html>
+</t:chloe>
--- a/bonerbonerboner/bonerbonerboner.factor
+++ b/bonerbonerboner/bonerbonerboner.factor
@ -0,0 +1,5 @@
+USING: kernel regexp dns hashtables sequences splitting assocs urls arrays http http.client json json.http io.sockets.secure accessors ;
+USING: prettyprint ;
+USING: io.encodings.utf8 io.encodings.string ;
+
+IN: bonerbonerboner
--- a/bonerbonerboner/dns/dns.factor
+++ b/bonerbonerboner/dns/dns.factor
@ -0,0 +1,44 @@
+USING: kernel regexp dns hashtables sequences splitting assocs urls arrays http http.client json json.http io.sockets.secure accessors ;
+USING: prettyprint ;
+
+IN: bonerbonerboner.dns
+
+CONSTANT: bbb-domain "bonerbonerboner.com"
+CONSTANT: meta R/ ^meta=/
+CONSTANT: do-key "TODO: ADD TO ENV"
+CONSTANT: do-api-base-url URL" https://api.digitalocean.com/v2/"
+
+: get-subdomain-metadata ( -- assoc )
+    bbb-domain dns-TXT-query TXT-message>strings
+    H{  }
+    [
+        first dup
+        meta re-contains?
+        [ swap [ meta "" re-replace ":" split [ second ] [ first ] bi ] dip ?set-at ]
+        [ drop ] if
+    ] reduce ;
+
+: get-subdomains ( -- seq )
+    get-subdomain-metadata keys ;
+
+: post-domain-records-url ( -- url )
+    do-api-base-url URL" domains/bonerbonerboner.com/records" derive-url ;
+
+: add-authorization ( request -- request' )
+    "Bearer " do-key append "Authorization" set-header ;
+
+: <json-post-request> ( data url -- post-request )
+    [ <json-post-data> ] dip
+    "POST" <json-request> swap >>post-data ;
+
+: create-subdomain-meta ( name color -- )
+    2array ":" join "meta=" prepend
+    'H{
+        { "data" _ }
+        { "name" "@" }
+        { "type" "TXT" }
+    }
+    post-domain-records-url
+    <json-post-request>
+    add-authorization
+    http-request 2drop ;
--- a/bonerbonerboner/server/server.factor
+++ b/bonerbonerboner/server/server.factor
@ -0,0 +1,22 @@
+USING: kernel http.server http.server.responses http.server.dispatchers accessors namespaces io.servers ;
+USING: bonerbonerboner.actions ;
+
+IN: bonerbonerboner.server
+
+SYMBOL: current-bbb-server
+
+: <bbb> ( -- responder )
+    bbb-dispatcher new-dispatcher
+    <404-subdomain-action> >>default
+    <heartbeat-action> "heartbeat" add-responder
+    <subdomain-action> "subdomains" add-responder
+    <meta-action> "meta" add-responder ;
+
+: <bbb-website-server> ( -- threaded-server )
+    <http-server>
+    f >>secure
+    8069 >>insecure ;
+
+: start-bbb-site ( -- )
+    <bbb> main-responder set-global
+    <bbb-website-server> start-server current-bbb-server set ;