Add /text endpoint
This commit is contained in:
parent
5bdf69ef91
commit
f5fd1089b1
32
app/Main.hs
32
app/Main.hs
@ -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
|
||||
|
@ -19,3 +19,9 @@ pre, code {
|
||||
pre {
|
||||
margin: 0; font-size: 0.5em;
|
||||
}
|
||||
|
||||
.charbox {
|
||||
text-align: center;
|
||||
width: 2em;
|
||||
font-size: 1em;
|
||||
}
|
||||
|
Loading…
x
Reference in New Issue
Block a user