Bump version to 0.4

.gitignore

@@ -1,3 +1,4 @@
 .stack-work/
 .vscode/
 *.swp
+result

README.md

@@ -1 +1,21 @@
 # utoy
+
+## Building the executable
+
+```
+$ $(nix-build utoy.nix)/bin/utoy
+```
+
+## Building the Docker image
+
+```
+$ docker load < $(nix-build nix/docker-image.nix)
+```
+
+## Development Shell
+
+Includes Stack, `haskell-language-server`, `gen-hie` etc.
+
+```
+$ nix-shell
+```

app/Main.hs

@@ -61,28 +61,35 @@ app :: Application
 app = serve (Proxy :: Proxy API) server
 
 type API =
-  "bytes" :> Capture "bytes" Text :> Get '[PlainText, HTML] BytesModel
-  :<|> "codepoints" :> Capture "codepoints" Text :> Get '[PlainText] CodepointsModel
+  "utf8" :> Capture "bytes" Text :> Get '[PlainText, HTML] Utf8Model
+  :<|> "codepoints" :> Capture "codepoints" Text :> Get '[PlainText, HTML] CodepointsModel
+  :<|> "text" :> Capture "text" Text :> Get '[HTML] TextModel
 
 server :: Server API
 server =
-  bytesR :<|> codepointsR
+  utf8R :<|> codepointsR :<|> textR
   where
-    bytesR bytesP = do
+    utf8R bytesP = do
       bytes <- Parsers.parseHexBytes bytesP `orThrow` const err400
-      pure $ BytesModel $ Decode.decodeUtf8 bytes
+      pure $ mkUtf8Model bytes
 
     codepointsR codepointsP = do
       codepoints' <- Parsers.parseCodepoints codepointsP `orThrow` const err400
       pure $ mkCodepointsModel codepoints'
 
+    textR textP = do
+      pure $ TextModel textP
+
 -- /bytes/<bytes>
 
-newtype BytesModel = BytesModel
+newtype Utf8Model = Utf8Model
   { codepoints :: [([Word8], Either String Char)]
   }
 
-instance MimeRender PlainText BytesModel where
+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
@@ -103,25 +110,19 @@ instance MimeRender PlainText BytesModel where
       | (bytes, eiC) <- model.codepoints
       ]
 
-instance MimeRender HTML BytesModel 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 "utoy.css")
-    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
+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 $ intercalate ", " $ maybeToList (UnicodeNames.name c) ++ map (++ "*") (UnicodeNames.nameAliases c)
+            H.td $ H.code $ H.toHtml $ fromMaybe "" $ blockName c
 
 -- /codepoints/<codepoints>
 
@@ -130,7 +131,14 @@ newtype CodepointsModel = CodepointsModel
   }
 
 mkCodepointsModel :: [(Word, Word)] -> CodepointsModel
-mkCodepointsModel = CodepointsModel . map go . concatMap (uncurry enumFromTo)
+mkCodepointsModel =
+  CodepointsModel
+  -- Limit number of returned codepoints. Otherwise it's
+  -- too easy to provoke massive response bodies with requests like
+  -- /codepoints/0-99999999
+  . take 100000
+  . map go
+  . concatMap (uncurry enumFromTo)
   where
     go codepoint = (codepoint, toChar codepoint)
 
@@ -158,6 +166,35 @@ instance MimeRender PlainText CodepointsModel where
     | (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 $ intercalate ", " $ maybeToList (UnicodeNames.name c) ++ map (++ "*") (UnicodeNames.nameAliases c)
+            H.td $ H.code $ H.toHtml $ fromMaybe "" $ blockName c
+
+-- /text/<text>
+
+newtype TextModel = TextModel
+  { text :: Text
+  }
+
+instance MimeRender HTML TextModel where
+  mimeRender _ model = renderHtml $ documentWithBody $ 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
@@ -167,7 +204,7 @@ showByteHex :: Word8 -> String
 showByteHex = printf "      %02X"
 
 showByteBin :: Word8 -> String
-showByteBin = printf "%8b"
+showByteBin = printf "%08b"
 
 blockName :: Char -> Maybe String
 blockName c = UnicodeBlocks.blockName . UnicodeBlocks.blockDefinition <$> UnicodeBlocks.block c
@@ -179,6 +216,15 @@ 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 body
+
 -- HTML routes
 
 data HTML

hie.yaml

@@ -4,7 +4,7 @@ cradle:
       component: "utoy:lib"
 
     - path: "./app/Main.hs"
-      component: "utoy:exe:utoy-exe"
+      component: "utoy:exe:utoy"
 
     - path: "./test"
       component: "utoy:test:utoy-test"

nix/docker-image.nix

@@ -0,0 +1,9 @@
+let
+  pkgs = import ./pkgs.nix {};
+  utoy = import ../utoy.nix;
+in
+  pkgs.dockerTools.buildImage {
+    name = "git.pbrinkmeier.de/paul/utoy";
+    tag = utoy.version;
+    config.Cmd = [ "${utoy}/bin/utoy" ];
+  }

package.yaml

@@ -1,7 +1,7 @@
 # Adapted from new-template.hsfiles
 
 name:                utoy
-version:             0.1.0.0
+version:             0.4
 git:                 "https://git.pbrinkmeier.de/paul/utoy"
 license:             MIT
 author:              "Paul Brinkmeier"
@@ -10,7 +10,7 @@ copyright:           "2023 Paul Brinkmeier"
 
 extra-source-files:
 - README.md
-- utoy.css
+- static/utoy.css
 
 dependencies:
 - base >= 4.7 && < 5
@@ -32,7 +32,7 @@ library:
   source-dirs: src
 
 executables:
-  utoy-exe:
+  utoy:
     main:                Main.hs
     source-dirs:         app
     ghc-options:

static/utoy.css

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

utoy.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           utoy
-version:        0.1.0.0
+version:        0.4
 author:         Paul Brinkmeier
 maintainer:     hallo@pbrinkmeier.de
 copyright:      2023 Paul Brinkmeier
@@ -14,7 +14,7 @@ license-file:   LICENSE
 build-type:     Simple
 extra-source-files:
     README.md
-    utoy.css
+    static/utoy.css
 
 source-repository head
   type: git
@@ -36,7 +36,7 @@ library
     , text
   default-language: Haskell2010
 
-executable utoy-exe
+executable utoy
   main-is: Main.hs
   hs-source-dirs:
       app

utoy.nix

@@ -0,0 +1,35 @@
+let
+  pkgs = import ./nix/pkgs.nix {};
+  settings = import ./nix/settings.nix;
+  haskellDeps = import ./nix/haskell-deps.nix;
+
+  haskellPackages = pkgs.haskell.packages."${settings.ghc}";
+
+  utoy =
+    { mkDerivation }:
+    mkDerivation {
+      version = "0.4";
+      pname = "utoy";
+      license = pkgs.lib.licenses.mit;
+      src =
+        let
+          buildFiles = [
+            ./LICENSE
+            ./utoy.cabal
+            ./Setup.hs
+            ./app
+            ./src
+            ./static
+            ./test
+          ];
+        in
+          pkgs.lib.sources.cleanSourceWith {
+            src = ./.;
+            filter = path: _type: pkgs.lib.any (prefix: pkgs.lib.hasPrefix (toString prefix) path) buildFiles;
+          };
+
+      libraryHaskellDepends = haskellDeps haskellPackages;
+    };
+in
+  pkgs.haskell.lib.justStaticExecutables
+    (haskellPackages.callPackage utoy {})