Add root route
This commit is contained in:
parent
e344ddefb5
commit
7c4fea02d1
14
app/Main.hs
14
app/Main.hs
@ -62,7 +62,7 @@ app :: Application
|
||||
app = serve (Proxy :: Proxy API) server
|
||||
|
||||
type API =
|
||||
Header "Host" Text :> Get '[PlainText] RootModel
|
||||
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
|
||||
@ -102,13 +102,21 @@ instance MimeRender PlainText RootModel where
|
||||
mimeRender _ model = renderText $ Text.unlines $
|
||||
[ "⚞ utoy ⚟"
|
||||
, ""
|
||||
, "This is utoy, a URL-based Unicode playground. You can try these paths:"
|
||||
, "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
|
||||
@ -270,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
|
||||
|
||||
|
Loading…
x
Reference in New Issue
Block a user