306 lines
9.0 KiB
Haskell
306 lines
9.0 KiB
Haskell
{-# LANGUAGE BinaryLiterals #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE NumericUnderscores #-}
|
|
{-# LANGUAGE OverloadedRecordDot #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
|
|
module Main (main) where
|
|
|
|
import Data.Char (chr)
|
|
import Data.FileEmbed (embedFile)
|
|
import Data.Foldable (for_)
|
|
import Data.Maybe (fromMaybe)
|
|
import Data.Text (Text)
|
|
import Data.Word (Word8)
|
|
import Network.HTTP.Media ((//), (/:))
|
|
import Network.Wai (Application)
|
|
import Servant
|
|
( Accept (..)
|
|
, Handler
|
|
, Header
|
|
, 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 UToy.Decode as Decode
|
|
import qualified UToy.Table as Table
|
|
import qualified UToy.Names as Names
|
|
import qualified UToy.Parsers as Parsers
|
|
|
|
main :: IO ()
|
|
main = Warp.run 3000 app
|
|
|
|
app :: Application
|
|
app = serve (Proxy :: Proxy API) server
|
|
|
|
type API =
|
|
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
|
|
:<|> "search" :> Capture "search" Text :> Get '[PlainText, HTML] SearchModel
|
|
|
|
server :: Server API
|
|
server =
|
|
rootR :<|> utf8R :<|> codepointsR :<|> textR :<|> searchR
|
|
where
|
|
rootR host' = do
|
|
pure $ RootModel $ fromMaybe "" host'
|
|
|
|
utf8R bytesP = do
|
|
bytes <- Parsers.parseHexBytes bytesP `orThrow` const err400
|
|
pure $ mkUtf8Model bytes
|
|
|
|
codepointsR codepointsP = do
|
|
codepoints' <- Parsers.parseCodepoints codepointsP `orThrow` const err400
|
|
pure $ mkCodepointsModel codepoints'
|
|
|
|
textR textP = do
|
|
pure $ TextModel textP
|
|
|
|
searchR searchP = do
|
|
pure $ mkSearchModel searchP
|
|
|
|
-- /
|
|
|
|
newtype RootModel = RootModel
|
|
{ host :: Text
|
|
}
|
|
|
|
examples :: [Text]
|
|
examples =
|
|
[ "/text/✅🤔"
|
|
, "/codepoints/x2705+x1F914"
|
|
, "/utf8/e2.9c.85.f0.9f.a4.94"
|
|
, "/search/asterisk"
|
|
]
|
|
|
|
instance MimeRender PlainText RootModel where
|
|
mimeRender _ model = renderText $ Text.unlines $
|
|
[ "⚞ utoy ⚟"
|
|
, ""
|
|
, "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
|
|
{ codepoints :: [([Word8], Either String Char)]
|
|
}
|
|
|
|
mkUtf8Model :: [Word8] -> Utf8Model
|
|
mkUtf8Model = Utf8Model . Decode.decodeUtf8
|
|
|
|
instance MimeRender PlainText Utf8Model where
|
|
mimeRender _ model = renderText $
|
|
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 ->
|
|
[ "Decoding error: " <> Text.pack err
|
|
]
|
|
Right c ->
|
|
[ Text.pack [c]
|
|
, Text.pack $ printf "U+%04X" c
|
|
, Text.intercalate ", " $ Names.allNames c
|
|
, fromMaybe "" $ Names.blockName c
|
|
]
|
|
)
|
|
]
|
|
| (bytes, eiC) <- model.codepoints
|
|
]
|
|
|
|
instance MimeRender HTML Utf8Model where
|
|
mimeRender _ model = renderHtml $ documentWithBody $ 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 $ H.input ! A.class_ "charbox" ! A.value (H.toValue [c])
|
|
H.td $ H.code $ printfHtml "U+%04X" c
|
|
H.td $ H.code $ H.toHtml $ Text.intercalate ", " $ Names.allNames c
|
|
H.td $ H.code $ H.toHtml $ fromMaybe "" $ Names.blockName c
|
|
|
|
-- /codepoints/<codepoints>
|
|
|
|
newtype CodepointsModel = CodepointsModel
|
|
{ codepoints :: [(Word, Either String Char)]
|
|
}
|
|
|
|
mkCodepointsModel :: [(Word, Word)] -> CodepointsModel
|
|
mkCodepointsModel =
|
|
CodepointsModel
|
|
-- Limit number of returned codepoints. Otherwise it's
|
|
-- too easy to provoke massive response bodies with requests like
|
|
-- /codepoints/0-99999999
|
|
. take 100_000
|
|
. map go
|
|
. concatMap (uncurry enumFromTo)
|
|
where
|
|
go codepoint = (codepoint, toChar codepoint)
|
|
|
|
toChar codepoint
|
|
| codepoint > 0x10_FFFF = Left "Would be too big (maximum: U+10FFFF)"
|
|
| isSurrogate codepoint = Left "Is a surrogate"
|
|
| otherwise = Right $ chr $ fromIntegral codepoint
|
|
|
|
isSurrogate codepoint = 0xD800 <= codepoint && codepoint <= 0xDFFF
|
|
|
|
instance MimeRender PlainText CodepointsModel where
|
|
mimeRender _ model = renderText $ Table.render " "
|
|
[ map Table.cl (Text.pack (printf "0x%X" codepoint)
|
|
: case eiC of
|
|
Left err ->
|
|
[ "Decoding error: " <> Text.pack err
|
|
]
|
|
Right c ->
|
|
[ Text.pack [c]
|
|
, Text.pack $ printf "U+%04X" c
|
|
, Text.intercalate ", " $ Names.allNames c
|
|
, fromMaybe "" $ Names.blockName c
|
|
]
|
|
)
|
|
| (codepoint, eiC) <- model.codepoints
|
|
]
|
|
|
|
instance MimeRender HTML CodepointsModel where
|
|
mimeRender _ model = renderHtml $ documentWithBody $ do
|
|
H.table $ for_ model.codepoints $ \(codepoint, eiC) ->
|
|
H.tr $ do
|
|
H.td $ H.code $ H.toHtml $ Text.pack $ printf "0x%X" codepoint
|
|
case eiC of
|
|
Left err -> do
|
|
H.td ! A.colspan "4" $ H.code $ H.toHtml $ "Decoding error: " <> Text.pack err
|
|
Right c -> 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 $ Text.intercalate ", " $ Names.allNames c
|
|
H.td $ H.code $ H.toHtml $ fromMaybe "" $ Names.blockName c
|
|
|
|
-- /text/<text>
|
|
|
|
newtype TextModel = TextModel
|
|
{ text :: Text
|
|
}
|
|
|
|
instance MimeRender HTML TextModel where
|
|
mimeRender _ model = charTableHtml $ Text.unpack model.text
|
|
instance MimeRender PlainText TextModel where
|
|
mimeRender _ model = charTableText $ Text.unpack model.text
|
|
|
|
-- /search/<search>
|
|
|
|
newtype SearchModel = SearchModel
|
|
{ results :: [Char]
|
|
}
|
|
|
|
mkSearchModel :: Text -> SearchModel
|
|
mkSearchModel search = SearchModel $ take 100_000 $ Names.searchCaseInsensitive search
|
|
|
|
instance MimeRender HTML SearchModel where
|
|
mimeRender _ model = charTableHtml model.results
|
|
|
|
instance MimeRender PlainText SearchModel where
|
|
mimeRender _ model = charTableText model.results
|
|
|
|
-- Utilities
|
|
|
|
charTableHtml :: [Char] -> BL.ByteString
|
|
charTableHtml chars =
|
|
renderHtml $ documentWithBody $ do
|
|
H.table $ for_ chars $ \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 $ Text.intercalate ", " $ Names.allNames c
|
|
H.td $ H.code $ H.toHtml $ fromMaybe "" $ Names.blockName c
|
|
|
|
|
|
charTableText :: [Char] -> BL.ByteString
|
|
charTableText chars =
|
|
renderText $ Table.render " "
|
|
[ map Table.cl
|
|
[ Text.pack [c]
|
|
, Text.pack $ printf "U+%04X" c
|
|
, Text.intercalate ", " $ Names.allNames c
|
|
, fromMaybe "" $ Names.blockName c
|
|
]
|
|
| c <- chars
|
|
]
|
|
|
|
renderText :: Text -> BL.ByteString
|
|
renderText = BL.fromStrict . Encoding.encodeUtf8
|
|
|
|
showByteHex :: Word8 -> String
|
|
showByteHex = printf " %02X"
|
|
|
|
showByteBin :: Word8 -> String
|
|
showByteBin = printf "%08b"
|
|
|
|
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
|
|
|
|
documentWithBody :: H.Html -> H.Html
|
|
documentWithBody body =
|
|
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 $ H.main body
|
|
|
|
-- HTML routes
|
|
|
|
data HTML
|
|
|
|
instance Accept HTML where
|
|
contentType _ = "text" // "html" /: ("charset", "utf-8")
|