{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}

-- the ToHtml class also provides a method without escaping which we don't use,
-- so it's safe to never define it
{-# OPTIONS_GHC -Wno-missing-methods #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Module containing orphan instances of Lucid's ToHtml, used for rendering
-- linter results as html
module HtmlOrphans () where

import           Universum

import           CheckDir        (DirResult (..), MissingAsset (MissingAsset),
                                  MissingDep (..), maximumLintLevel)
import           CheckMap        (MapResult (..))
import           Data.List.Extra (escapeJSON)
import qualified Data.Map        as M
import           Handlers        (AdminOverview (..))
import           Lucid           (HtmlT, ToHtml)
import           Lucid.Base      (ToHtml (toHtml))
import           Lucid.Html5     (a_, body_, button_, class_, code_, disabled_,
                                  div_, em_, h1_, h2_, h3_, h4_, h5_, head_,
                                  href_, html_, id_, li_, link_, main_,
                                  onclick_, p_, rel_, script_, span_, src_,
                                  title_, type_, ul_)
import           Server          (JobStatus (..), Org (orgSlug),
                                  RemoteRef (reporef, repourl), prettySha,
                                  unState)
import           Types           (Hint (Hint), Level (..))


import           Fmt

mono :: Monad m => HtmlT m () -> HtmlT m ()
mono = code_ [class_ "small text-muted"]


htmldoc :: Monad m => HtmlT m () -> HtmlT m ()
htmldoc inner = html_ $ do
    head_ $ do
      title_ "Job Status"
      link_ [rel_ "stylesheet", type_ "text/css", href_ "/bootstrap.min.css" ]
      link_ [rel_ "stylesheet", type_ "text/css", href_ "/style.css" ]
    body_ $ main_ [class_ "main-content"] inner

instance ToHtml JobStatus where
  toHtml status = htmldoc $ case status of
      Pending _ -> do
        h1_ "Pending …"
        p_ "(please note that this site won't auto-reload, you'll have to refresh it yourself)"
        autoReloadScript
      Linted res _rev (pending, _) -> do
        h1_ "Linter Result"
        if pending
          then button_ [class_ "btn btn-primary btn-disabled", disabled_ "true"] "pending …"
          else button_ [onclick_ "relint()", class_ "btn btn-primary", id_ "relint_button"] "relint"
        toHtml res
        script_
          "function relint() {\n\
          \  var xhr = new XMLHttpRequest ();\n\
          \  xhr.open('POST', 'relint', true);\n\
          \  xhr.onreadystatechange = (e) => {if (xhr.status == 200) {\n\
          \    console.log(e);\n\
          \  }}\n\
          \  xhr.send(null);\n\
          \}"
        autoReloadScript
      Failed err -> do
        h1_ "System Error"
        p_ $ "error: " <> toHtml err
        p_ "you should probably ping an admin about this or sth"
      where
        autoReloadScript = script_
          "let proto = window.location.protocol === 'https://' ? 'wss' : 'ws://';\
          \let ws = new WebSocket(proto + window.location.host + window.location.pathname + 'realtime');\n\
          \ws.onmessage = (event) => {\n\
          \  let resp = JSON.parse(event.data);\n\
          \  if (resp == 'RelintPending') {\n\
          \    let btn = document.getElementById('relint_button');\n\
          \    btn.innerText = 'pending …';\n\
          \    btn.disabled = true;\n\
          \    btn.class = 'btn btn-disabled';\n\
          \  } else if (resp == 'Reload') {\n\
          \    location.reload();\n\
          \  }\n\
          \}"

instance ToHtml AdminOverview where
  toHtml (AdminOverview state) = htmldoc $ do
    h1_ "Map List"
    forM_ (view unState state) $ \(org, jobs) -> do
      h2_ (toHtml $ orgSlug org)
      if null jobs then em_ "(nothing yet)"
      else flip M.foldMapWithKey jobs $ \sha1 (ref, status) -> li_ $ do
        case status of
          Pending _          -> badge Info "pending"
          (Linted res rev _) -> toHtml $ maximumLintLevel res
          (Failed _)         -> badge Error "system error"
        " "; a_ [href_ ("/status/"+|orgSlug org|+"/"+|prettySha sha1|+"/")] $ do
          mono $ toHtml $ reporef ref; " on "; mono $ toHtml $ repourl ref


badge :: Monad m => Level -> HtmlT m () -> HtmlT m ()
badge level = span_ [class_ badgetype]
    where badgetype = case level of
            Info       -> "badge badge-info"
            Suggestion -> "badge badge-info"
            Warning    -> "badge badge-warning"
            Forbidden  -> "badge badge-danger"
            Error      -> "badge badge-danger"
            Fatal      -> "badge badge-danger"

-- | Lint Levels directly render into badges
instance ToHtml Level where
  toHtml level = badge level (toHtml (show level :: Text))

-- | Hints are just text with a level
instance ToHtml Hint where
  toHtml (Hint level msg) = do
    toHtml level; " "; toHtml msg


headerText :: Monad m => Level -> HtmlT m ()
headerText = \case
  Info  -> "Couldn't find a thing to complain about. Congratulations!"
  Suggestion -> "There's a couple smaller nitpicks; maybe take a look at those?"
  Warning -> "The map is fine, but some things look like they might be mistakes; \
             \perhaps you want to take a look at those?"
  Forbidden -> "The map is fine in principle, but contains things that are not\
               \allowed at this event"
  Error -> "Your map currently contains errors and should probably be fixed"
  Fatal -> "Something broke while linting; if you're not sure why or how to make \
           \it work, feel free to tell an admin about it"


-- | The fully monky
instance ToHtml (DirResult a) where
  toHtml res@DirResult { .. } = do

    p_ $ do badge maxlevel "Linted:"; " "; headerText maxlevel

    h2_ "Exits"
    unless (null dirresultDeps) $ ul_ $
      forM_ dirresultDeps $ \missing -> do
        li_ $ do
          -- TODO: the whole Maybe Bool thing is annoying; I think that was a
          -- remnant of talking to python stuff and can probably be removed?
          if depFatal missing == Just True
            then do { toHtml Error; "Map " }
            else do { toHtml Warning; "Entrypoint " }
          code_ $ toHtml (entrypoint missing)
          " does not exist"
          unless (depFatal missing /= Just True) $ do
            " (no layer with that name is a "; mono "startLayer"; ")"
          ", but is used as "; mono "exitUrl"; " in "
          placeList (neededBy missing); "."

    -- the exit graph thing
    script_ [ src_ "/dot-wasm.js" ] (""::Text)
    script_ [ src_ "/d3.js" ] (""::Text)
    script_ [ src_ "/d3-graphviz.js" ] (""::Text)
    div_ [ id_ "exitGraph" ] ""
    script_ $
      "\
      \d3.select(\"#exitGraph\")\n\
      \  .graphviz()\n\
      \  .dot(\"" <> toText (escapeJSON $ toString dirresultGraph) <> "\")\n\
      \  .render()\n\
      \"

    unless (null dirresultMissingAssets) $ do
      h2_ [class_ "border-bottom"] "Assets"
      ul_ $ forM_ dirresultMissingAssets $
        \(MissingAsset MissingDep { .. }) -> li_ $ do
          toHtml Error; "File "; mono $ toHtml entrypoint
          " does not exist, but is referenced in "; placeList neededBy; ")"

    unless (null dirresultMaps) $ do
      h3_ "Maps"
      flip M.foldMapWithKey dirresultMaps $ \name MapResult { .. } -> do
        h4_ (toHtml name)
        ul_ $ forM_ mapresultGeneral $ \lint ->
          li_ (toHtml lint)
        h5_ "Layers"
        ul_ (listMapWithKey mapresultLayer)
        h5_ "Tilesets"
        ul_ (listMapWithKey mapresultTileset)

    where
      maxlevel = maximumLintLevel res

      placeList :: (Monad m, ToHtml a) => [a] -> HtmlT m ()
      placeList occurances =
        sequence_ . intersperse ", " $ occurances <&> \place ->
          code_ [class_ "small text-muted"] (toHtml place)

      listMapWithKey map =
        flip M.foldMapWithKey map $ \lint places ->
          li_ $ do toHtml lint; " (in "; placeList places; ")"