paul/utoy
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Add plain text version of /hex

Browse Source
This commit is contained in:
Paul Brinkmeier 2023-03-01 03:41:39 +01:00
parent 69d9e21c80
commit 59575fe7ad
1 changed files with 26 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
app/Main.hs
View File

@ -23,6 +23,7 @@ import Servant
, MimeRender (..) , MimeRender (..)
, Server , Server
, ServerError (..) , ServerError (..)
, PlainText
, Proxy (..) , Proxy (..)
, Capture , Capture
, Get , Get
@ -35,6 +36,8 @@ import Text.Blaze.Html5 ((!))
import Text.Blaze.Html.Renderer.Utf8 (renderHtml) import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
import Text.Printf (PrintfArg, printf) import Text.Printf (PrintfArg, printf)
import qualified Data.Text.Lazy as Text
import qualified Data.Text.Lazy.Encoding as Encoding
import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Handler.Warp as Warp
import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A import qualified Text.Blaze.Html5.Attributes as A
@ -51,7 +54,7 @@ app :: Application
app = serve (Proxy :: Proxy API) server app = serve (Proxy :: Proxy API) server
type API = type API =
"hex" :> Capture "bytes" Text :> Get '[HTML] HexModel "hex" :> Capture "bytes" Text :> Get '[PlainText, HTML] HexModel
server :: Server API server :: Server API
server = server =
@ -65,6 +68,22 @@ newtype HexModel = HexModel
{ codepoints :: [([Word8], Either String Char)] { codepoints :: [([Word8], Either String Char)]
} }
instance MimeRender PlainText HexModel where
mimeRender _ model = Encoding.encodeUtf8 $ Text.intercalate "\n" $ concat
[ [ Text.pack $ unwords $ map showByteHex bytes
, Text.intercalate " " $
Text.pack (unwords $ map showByteBin bytes)
: case eiC of
Left err -> [Text.pack err]
Right c -> map Text.pack
[ [c]
, printf "U+%04X" c
, intercalate ", " $ maybeToList (UnicodeNames.name c) ++ map (++ "*") (UnicodeNames.nameAliases c)
]
]
| (bytes, eiC) <- model.codepoints
]
instance MimeRender HTML HexModel where instance MimeRender HTML HexModel where
mimeRender _ model = renderHtml $ H.docTypeHtml $ do mimeRender _ model = renderHtml $ H.docTypeHtml $ do
H.head $ do H.head $ do
@ -85,14 +104,18 @@ instance MimeRender HTML HexModel where
H.td $ H.code $ H.toHtml $ intercalate ", " $ maybeToList (UnicodeNames.name c) ++ map (++ "*") (UnicodeNames.nameAliases 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.toHtml $ fromMaybe "" $ blockName c
where where
showByteHex = printf " %02X"
showByteBin = printf "%8b"
blockName :: Char -> Maybe String blockName :: Char -> Maybe String
blockName c = UnicodeBlocks.blockName . UnicodeBlocks.blockDefinition <$> UnicodeBlocks.block c blockName c = UnicodeBlocks.blockName . UnicodeBlocks.blockDefinition <$> UnicodeBlocks.block c
-- Utilities -- Utilities
showByteHex :: Word8 -> String
showByteHex = printf " %02X"
showByteBin :: Word8 -> String
showByteBin = printf "%8b"
orThrow :: Either a b -> (a -> ServerError) -> Handler b orThrow :: Either a b -> (a -> ServerError) -> Handler b
orThrow (Left err) f = throwError $ f err orThrow (Left err) f = throwError $ f err
orThrow (Right val) _ = pure val orThrow (Right val) _ = pure val