From e344ddefb5705056de951e5083925896616670c4 Mon Sep 17 00:00:00 2001
From: Paul Brinkmeier <hallo@pbrinkmeier.de>
Date: Thu, 6 Apr 2023 13:56:57 +0200
Subject: [PATCH] Add plaintext root

---
 app/Main.hs | 35 ++++++++++++++++++++++++++++++++---
 1 file changed, 32 insertions(+), 3 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index f430ee6..18ba32f 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -24,6 +24,7 @@ import Network.Wai (Application)
 import Servant
   ( Accept (..)
   , Handler
+  , Header
   , MimeRender (..)
   , Server
   , ServerError (..)
@@ -61,14 +62,18 @@ app :: Application
 app = serve (Proxy :: Proxy API) server
 
 type API =
-  "utf8" :> Capture "bytes" Text :> Get '[PlainText, HTML] Utf8Model
+  Header "Host" Text :> Get '[PlainText] RootModel
+  :<|> "utf8" :> Capture "bytes" Text :> Get '[PlainText, HTML] Utf8Model
   :<|> "codepoints" :> Capture "codepoints" Text :> Get '[PlainText, HTML] CodepointsModel
   :<|> "text" :> Capture "text" Text :> Get '[PlainText, HTML] TextModel
 
 server :: Server API
 server =
-  utf8R :<|> codepointsR :<|> textR
+  rootR :<|> utf8R :<|> codepointsR :<|> textR
   where
+    rootR host = do
+      pure $ RootModel $ fromMaybe "" host
+
     utf8R bytesP = do
       bytes <- Parsers.parseHexBytes bytesP `orThrow` const err400
       pure $ mkUtf8Model bytes
@@ -80,6 +85,30 @@ server =
     textR textP = do
       pure $ TextModel textP
 
+-- /
+
+newtype RootModel = RootModel
+  { host :: Text
+  }
+
+examples :: [Text]
+examples =
+  [ "/text/✅🤔"
+  , "/codepoints/x2705+x1F914"
+  , "/utf8/e2.9c.85.f0.9f.a4.94"
+  ]
+
+instance MimeRender PlainText RootModel where
+  mimeRender _ model = renderText $ Text.unlines $
+    [ "⚞ utoy ⚟"
+    , ""
+    , "This is utoy, a URL-based Unicode playground. You can try these paths:"
+    , ""
+    ] ++ map (urlBase <>) examples
+    where
+      -- We assume HTTPS here. Doesn't work for development on localhost.
+      urlBase = "https://" <> model.host
+
 -- /bytes/<bytes>
 
 newtype Utf8Model = Utf8Model
@@ -197,7 +226,7 @@ instance MimeRender HTML TextModel where
 
 instance MimeRender PlainText TextModel where
   mimeRender _ model = renderText $ Table.render "  "
-    [ map (Table.cl)
+    [ map Table.cl
       [ Text.pack [c]
       , Text.pack $ printf "U+%04X" c
       , Text.pack $ intercalate ", " $ allNames c