{-# 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")