Main.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Main (main, handlers) where

import Control.Monad (forM_)
import Data.Aeson qualified as J
import Data.Aeson.Key qualified as AK
import Data.Aeson.KeyMap qualified as AKM
import Data.ByteString.Builder qualified as BB
import Data.ByteString.Char8 qualified as BS8
import Data.ByteString.Lazy qualified as LBS
import Data.ByteString.Lazy.Char8 qualified as LBS8
import Data.CaseInsensitive qualified as CI
import Data.Function (fix, (&))
import Data.Text.Lazy qualified as LT
import Data.Text.Lazy.Encoding qualified as LTE
import Data.Vector.Unboxed.Mutable qualified as MU
import Effectful
import Effectful.Concurrent (Concurrent, runConcurrent)
import Effectful.Prim
import Effectful.Random.Static (Random, evalRandom, newStdGen, uniform)
import Lucid
import Network.HTTP.Types (encodePathSegments, renderQuery)
import Steward.Demo.Fib.Types
import Steward.Workers

foreign export javascript "handlers" handlers :: IO JSHandlers

handlers :: IO JSHandlers
handlers = toJSHandlers Handlers {fetch = fetcher}

type Bound = BindingsClass '[] '[] '[]

fetcher :: FetchHandler Bound
fetcher = runWorker $ do
  g <- newStdGen
  runConcurrent $ runPrim $ evalRandom g $ fromHandlers @Bound endpoints

endpoints ::
  ( Random :> es
  , Prim :> es
  , Concurrent :> es
  , Worker Bound :> es
  ) =>
  FibEndpoints (Handler (Eff es))
endpoints =
  FibEndpoints
    { random = Handler serveRandom
    , index = Handler indexPage
    , fib = Handler serveFib
    }

serveFib ::
  (Prim :> es) =>
  Int ->
  Eff es FibResult
serveFib n = do
  mv <- MU.new $ n + 1
  MU.write mv 0 0
  MU.write mv 1 1
  2 & fix \self !i ->
    if i > n
      then pure ()
      else do
        k <- MU.read mv $ i - 2
        l <- MU.read mv $ i - 1
        MU.write mv i $ k + l
        self $ i + 1
  result <- MU.read mv n
  pure FibResult {input = n, ..}

indexPage ::
  (Worker Bound :> es) =>
  Eff es (Either LBS.ByteString (Html ()))
indexPage = do
  mcf <- getCloudflareJSON @Bound
  req <- getStewardRequest @Bound
  pure $ Right $ buildResponseBody mcf req

serveRandom ::
  (Concurrent :> es, Random :> es) =>
  Eff es Int
serveRandom = uniform

buildResponseBody :: Maybe J.Value -> StewardRequest -> Html ()
buildResponseBody mcf req = do
  let method = show req.method
      url = toUrl req
      hdrs = req.headers
  doctype_
  html_ $ do
    head_ $ do
      title_ "Hello Worker, From GHC, with Love!"
      link_ [rel_ "stylesheet", href_ "https://cdn.simplecss.org/simple-v1.css"]
    body_ $ do
      h1_ "Hello Worker, From GHC, with Love!"
      p_ do
        "["
        a_ [href_ "https://github.com/konn/ghc-wasm-earthly/blob/main/steward-fib-demo/app/worker/Main.hs"] "Source Code"
        "]"
      h2_ "Info"
      p_ "Proudedly generated by GHC WASM backend."
      h2_ "Fibonacci!"
      p_ do
        "Calculate Fibonacci number (via Workers!): "
      p_ do
        input_ [type_ "text", id_ "fib-input", placeholder_ "12"]
        button_ [id_ "calc-fib"] "Fib"
      p_ do
        "Fib: "
        span_ [id_ "fib-result"] ""
      h2_ "Random Number Generation"
      p_ do
        "Generate a random number (via Workers!): "
        button_ [id_ "gen-rand"] "Random"
      p_ do
        "Random: "
        span_ [id_ "random-result"] ""
      h2_ "Metadata"
      table_ do
        thead_ do
          tr_ do
            th_ [scope_ "col"] "Property"
            th_ [scope_ "col"] "Value"
        tbody_ do
          tr_ do
            th_ [scope_ "row"] "Method"
            td_ $ toHtml method
          tr_ do
            th_ [scope_ "row"] "Url"
            td_ $ code_ $ toHtml url
      h2_ "Headers"
      table_ do
        thead_ do
          tr_ do
            th_ [scope_ "col"] "Header"
            th_ [scope_ "col"] "Value"
        tbody_ $ forM_ hdrs \(l, r) ->
          tr_ do
            th_ [scope_ "row"] $ toHtml $ BS8.unpack $ CI.foldedCase l
            td_ $ code_ $ toHtml $ BS8.unpack r

      h2_ "Cloudflare Workers Specific Request Properties"
      case mcf of
        Nothing -> p_ "N/A"
        Just (J.Array xs) -> ul_ $ mapM_ (li_ . toHtml . J.encode) xs
        Just (J.Object dic) -> table_ do
          thead_ do
            tr_ do
              th_ [scope_ "col"] "Property"
              th_ [scope_ "col"] "Value"
          let dic' =
                AKM.toList $
                  AKM.delete "tlsExportedAuthenticator" $
                    AKM.delete "tlsClientExtensionsSha1" $
                      AKM.delete "tlsClientRandom" $
                        AKM.delete "tlsClientAuth" $
                          AKM.delete "botManagement" dic
          tbody_ $ forM_ dic' \(k, v) -> do
            tr_ do
              th_ [scope_ "row"] $ toHtml $ AK.toText k
              td_ $
                code_ $
                  toHtml $
                    J.encode v
        Just v -> pre_ $ code_ $ toHtml $ J.encode v
      h2_ "Body"
      if LBS.null req.body
        then p_ "N/A"
        else pre_ $ code_ $ toHtml $ LTE.decodeUtf8 req.body
  script_ [type_ "text/javascript", async_ ""] startupScript

startupScript :: LT.Text
startupScript =
  LT.unlines
    [ "const fibButton = document.getElementById(\"calc-fib\");"
    , "fibButton.addEventListener('click', async () => {"
    , "  const fibInput = document.getElementById(\"fib-input\")"
    , "  const fibResult = document.getElementById(\"fib-result\")"
    , "  const num = fibInput.value;"
    , "  const resp = await fetch(`./fib/${num}`);"
    , "  const result = await resp.json();"
    , "  fibResult.innerText = JSON.stringify(result);"
    , "});"
    , "const randButton = document.getElementById(\"gen-rand\");"
    , "randButton.addEventListener('click', async () => {"
    , "  const randResult = document.getElementById(\"random-result\")"
    , "  const resp = await fetch(\"./random\");"
    , "  const result = await resp.json();"
    , "  randResult.innerText = JSON.stringify(result);"
    , "});"
    ]

toUrl :: StewardRequest -> String
toUrl req =
  let proto
        | req.secure = "https://"
        | otherwise = "http://"
   in LBS8.unpack $ BB.toLazyByteString $ proto <> BB.byteString req.host <> BB.byteString req.port <> encodePathSegments req.pathInfo <> BB.byteString (renderQuery True req.queryString)

main :: IO ()
main = pure ()