Add /text endpoint

This commit is contained in:
Paul Brinkmeier 2023-03-10 18:46:34 +01:00
parent 5bdf69ef91
commit f5fd1089b1
2 changed files with 34 additions and 4 deletions

View File

@ -63,10 +63,11 @@ app = serve (Proxy :: Proxy API) server
type API =
"bytes" :> Capture "bytes" Text :> Get '[PlainText, HTML] BytesModel
:<|> "codepoints" :> Capture "codepoints" Text :> Get '[PlainText] CodepointsModel
:<|> "text" :> Capture "text" Text :> Get '[HTML] TextModel
server :: Server API
server =
bytesR :<|> codepointsR
bytesR :<|> codepointsR :<|> textR
where
bytesR bytesP = do
bytes <- Parsers.parseHexBytes bytesP `orThrow` const err400
@ -76,6 +77,9 @@ server =
codepoints' <- Parsers.parseCodepoints codepointsP `orThrow` const err400
pure $ mkCodepointsModel codepoints'
textR textP = do
pure $ TextModel textP
-- /bytes/<bytes>
newtype BytesModel = BytesModel
@ -118,10 +122,10 @@ instance MimeRender HTML BytesModel where
H.td ! A.colspan "4" $ H.toHtml $ "Decoding error: " ++ err
Right c -> do
H.td $ do
H.input ! A.value (H.toValue [c]) ! A.style "text-align: center; width: 2em; font-size: 1em;"
H.td $ H.code $ printfHtml "U+%04X" c
H.input ! A.class_ "charbox" ! A.value (H.toValue [c])
H.td $ H.code $ printfHtml "U+%04X" c
H.td $ H.code $ H.toHtml $ intercalate ", " $ maybeToList (UnicodeNames.name c) ++ map (++ "*") (UnicodeNames.nameAliases c)
H.td $ H.toHtml $ fromMaybe "" $ blockName c
H.td $ H.code $ H.toHtml $ fromMaybe "" $ blockName c
-- /codepoints/<codepoints>
@ -158,6 +162,26 @@ instance MimeRender PlainText CodepointsModel where
| (codepoint, eiC) <- model.codepoints
]
-- /text/<text>
newtype TextModel = TextModel
{ text :: Text
}
instance MimeRender HTML TextModel where
mimeRender _ model = renderHtml $ H.docTypeHtml $ do
H.head $ do
H.meta ! A.charset "utf-8"
H.title "utoy"
H.style $ H.toHtml $ Encoding.decodeUtf8 $(embedFile "static/utoy.css")
H.body $ do
H.table $ for_ (Text.unpack model.text) $ \c -> do
H.tr $ do
H.td $ H.input ! A.class_ "charbox" ! A.value (H.toValue [c])
H.td $ H.code $ printfHtml "U+%04X" c
H.td $ H.code $ H.toHtml $ intercalate ", " $ maybeToList (UnicodeNames.name c) ++ map (++ "*") (UnicodeNames.nameAliases c)
H.td $ H.code $ H.toHtml $ fromMaybe "" $ blockName c
-- Utilities
renderText :: Text -> BL.ByteString

View File

@ -19,3 +19,9 @@ pre, code {
pre {
margin: 0; font-size: 0.5em;
}
.charbox {
text-align: center;
width: 2em;
font-size: 1em;
}