Add root route

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, HTML] 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,38 @@ 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. Examples:"
+    , ""
+    ] ++ map (urlBase <>) examples
+    where
+      -- We assume HTTPS here. Doesn't work for development on localhost.
+      urlBase = "https://" <> model.host
+
+instance MimeRender HTML RootModel where
+  mimeRender _ model = renderHtml $ documentWithBody $ do
+    H.h1 $ H.toHtml ("⚞ utoy ⚟" :: Text)
+    H.p $ H.toHtml ("This is utoy, a URL-based Unicode playground. Examples:" :: Text)
+    H.ul $ for_ examples $ \example -> do
+      let url = "https://" <> model.host <> example
+      H.li $ H.a ! A.href (H.toValue url) $ H.toHtml example
+
 -- /bytes/<bytes>
 
 newtype Utf8Model = Utf8Model
@@ -197,7 +234,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
@@ -241,7 +278,7 @@ documentWithBody body =
       H.meta ! A.charset "utf-8"
       H.title "utoy"
       H.style $ H.toHtml $ Encoding.decodeUtf8 $(embedFile "static/utoy.css")
-    H.body body
+    H.body $ H.main body
 
 -- HTML routes
 

flake.nix

@@ -21,9 +21,7 @@
 
         # The build is simply a call to makeWrapper, so we don't have to
         # do any of the typical build steps.
-        dontUnpack = true;
-        dontConfigure = true;
-        dontBuild = true;
+        phases = [ "installPhase" ];
 
         nativeBuildInputs = [ pkgs.makeWrapper ];
         # makeBinaryWrapper creates a stack executable for us that uses