137 lines
4.1 KiB
Haskell
137 lines
4.1 KiB
Haskell
{-# LANGUAGE BinaryLiterals #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE OverloadedRecordDot #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
|
|
module Main (main) where
|
|
|
|
import Data.Foldable (for_)
|
|
import Data.List (intercalate)
|
|
import Data.Maybe (fromMaybe, maybeToList)
|
|
import Data.Text (Text)
|
|
import Data.Word (Word8)
|
|
import Network.HTTP.Media ((//), (/:))
|
|
import Network.Wai (Application)
|
|
import Servant
|
|
( Accept (..)
|
|
, Handler
|
|
, MimeRender (..)
|
|
, Server
|
|
, ServerError (..)
|
|
, PlainText
|
|
, Proxy (..)
|
|
, Capture
|
|
, Get
|
|
, err400
|
|
, serve
|
|
, throwError
|
|
, (:>)
|
|
)
|
|
import Text.Blaze.Html5 ((!))
|
|
import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
|
|
import Text.Printf (PrintfArg, printf)
|
|
|
|
import qualified Data.ByteString.Lazy as BL
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.Encoding as Encoding
|
|
import qualified Network.Wai.Handler.Warp as Warp
|
|
import qualified Text.Blaze.Html5 as H
|
|
import qualified Text.Blaze.Html5.Attributes as A
|
|
import qualified Unicode.Char.General.Blocks as UnicodeBlocks
|
|
import qualified Unicode.Char.General.Names as UnicodeNames
|
|
|
|
import qualified UToy.Decode as Decode
|
|
import qualified UToy.Table as Table
|
|
import qualified UToy.Parsers as Parsers
|
|
|
|
main :: IO ()
|
|
main = Warp.run 3000 app
|
|
|
|
app :: Application
|
|
app = serve (Proxy :: Proxy API) server
|
|
|
|
type API =
|
|
"hex" :> Capture "bytes" Text :> Get '[PlainText, HTML] HexModel
|
|
|
|
server :: Server API
|
|
server =
|
|
hex
|
|
where
|
|
hex bytesP = do
|
|
bytes <- Parsers.parseHexBytes bytesP `orThrow` const err400
|
|
pure $ HexModel $ Decode.decodeUtf8 bytes
|
|
|
|
newtype HexModel = HexModel
|
|
{ codepoints :: [([Word8], Either String Char)]
|
|
}
|
|
|
|
instance MimeRender PlainText HexModel where
|
|
mimeRender _ model = BL.fromStrict $ Encoding.encodeUtf8 $
|
|
Table.render " " $ concat
|
|
[ [ [ Table.cl $ Text.pack $ unwords $ map showByteHex bytes
|
|
]
|
|
, map Table.cl (Text.pack (unwords $ map showByteBin bytes)
|
|
: case eiC of
|
|
Left err ->
|
|
[ Text.pack err
|
|
]
|
|
Right c ->
|
|
[ Text.pack $ printf "U+%04X" c
|
|
, Text.pack $ intercalate ", " $ maybeToList (UnicodeNames.name c) ++ map (++ "*") (UnicodeNames.nameAliases c)
|
|
, Text.pack $ fromMaybe "" $ blockName c
|
|
]
|
|
)
|
|
]
|
|
| (bytes, eiC) <- model.codepoints
|
|
]
|
|
|
|
instance MimeRender HTML HexModel where
|
|
mimeRender _ model = renderHtml $ H.docTypeHtml $ do
|
|
H.head $ do
|
|
H.meta ! A.charset "utf-8"
|
|
H.title "utoy"
|
|
H.style "html { font-size: 32px; font-family: 'Noto Sans', sans-serif; } td { padding: 0.5em 1em; } pre { margin: 0; font-size: 0.5em; } body { display: flex; justify-content: center; }"
|
|
H.body $ do
|
|
H.table $ for_ model.codepoints $ \(bytes, eiC) -> do
|
|
H.tr $ do
|
|
H.td $ H.pre $ H.toHtml $ unlines $ map unwords [map showByteHex bytes, map showByteBin bytes]
|
|
case eiC of
|
|
Left err ->
|
|
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.td $ H.code $ H.toHtml $ intercalate ", " $ maybeToList (UnicodeNames.name c) ++ map (++ "*") (UnicodeNames.nameAliases c)
|
|
H.td $ H.toHtml $ fromMaybe "" $ blockName c
|
|
|
|
-- Utilities
|
|
|
|
showByteHex :: Word8 -> String
|
|
showByteHex = printf " %02X"
|
|
|
|
showByteBin :: Word8 -> String
|
|
showByteBin = printf "%8b"
|
|
|
|
blockName :: Char -> Maybe String
|
|
blockName c = UnicodeBlocks.blockName . UnicodeBlocks.blockDefinition <$> UnicodeBlocks.block c
|
|
|
|
orThrow :: Either a b -> (a -> ServerError) -> Handler b
|
|
orThrow (Left err) f = throwError $ f err
|
|
orThrow (Right val) _ = pure val
|
|
|
|
printfHtml :: PrintfArg a => String -> a -> H.Html
|
|
printfHtml fmt = (H.toHtml :: String -> H.Html) . printf fmt
|
|
|
|
-- HTML routes
|
|
|
|
data HTML
|
|
|
|
instance Accept HTML where
|
|
contentType _ = "text" // "html" /: ("charset", "utf-8")
|