{-# LANGUAGE DataKinds         #-}
{-# 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           hiding (view)

import           CheckDir            (DirResult (..),
                                      MissingAsset (MissingAsset),
                                      MissingDep (..), maximumLintLevel)
import           CheckMap            (MapResult (..))
import           Data.List.Extra     (escapeJSON)
import qualified Data.Map            as M
import qualified Data.Text           as T
import           Handlers            (AdminOverview (..))
import           Lens.Micro.Platform (view)
import           Lucid               (HtmlT, ToHtml)
import           Lucid.Base          (ToHtml (toHtml))
import           Lucid.Html5         (a_, body_, button_, class_, code_,
                                      disabled_, div_, em_, h1_, h2_, h3_, h4_,
                                      head_, href_, html_, id_, li_, link_,
                                      main_, onclick_, p_, rel_, script_, span_,
                                      src_, title_, type_, ul_)
import           Server              (JobStatus (..),
                                      Org (Org, orgBacklinkPrefix, orgContactMail, orgHowtoLink, orgSlug),
                                      RemoteRef (RemoteRef, reponame, 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 (Org True, RemoteRef, JobStatus, Maybe JobStatus) where
  toHtml (org@Org{..}, ref@RemoteRef{..}, status, published) = htmldoc $ case status of
      Pending _ -> do
        h1_ "Pending …"
        autoReloadScript
      Linted res rev (pending, _) -> do
        h1_ $ do
          "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"
          whenJust orgHowtoLink $ \link ->
            a_ [class_ "btn btn-primary", href_ link] "Howto"
          a_ [class_ "btn btn-primary"
             , href_ ("mailto:" <> orgContactMail <> "?subject=[Help-walint] " <> reponame <> " " <> rev)]
             "Help?"
        p_ $ do
          "For commit "; code_ (toHtml $ T.take 7 rev); " of repository "
          code_ (toHtml repourl); " (on "; code_ (toHtml reporef); ")"
        p_ $ case published of
          Just (Linted _ rev _) ->
            do "Currently published commit: "; code_ (toHtml $ T.take 7 rev); "."
          _ -> "This Map has not yet been published."
        toHtml (org,ref,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, _lastvalid) -> li_ $ do
        case status of
          Pending _        -> badge Info "pending"
          (Linted res _ _) -> 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"

-- | pseudo-level badge when we don't even have an info lint
-- (rare, but it does happen!)
badgeHurray :: Monad m => HtmlT m() -> HtmlT m ()
badgeHurray = span_ [class_ "badge badge-success"]

-- | Lint Levels directly render into badges
instance ToHtml Level where
  toHtml level = do badge level (show level); " "

-- | 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? \
    \But overall the map looks great!"
  Warning ->
    "The map is fine, but some things look like they might be mistakes; \
    \perhaps you want to take a look at those?"
  Forbidden ->
    "While this map might work well with workadventure, it contains \
    \things that are not allowed at this event. Please change those \
    \so we can publish the map"
  Error ->
    "Your map currently contains errors. You will have to fix those before \
    \we can publish your map."
  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 (Org True, RemoteRef, DirResult a) where
  toHtml (Org {..}, RemoteRef {..}, res@DirResult { .. }) = do

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

    h2_ "Exits"

    p_ $ do
      "Note: to link back to the lobby, please use "
      code_ $ toHtml $ orgBacklinkPrefix <> reponame
      " as exitUrl."

    -- 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().engine(\"fdp\")\n\
      \  .dot(\"" <> toText (escapeJSON $ toString dirresultGraph) <> "\")\n\
      \  .render()\n\
      \"

    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); "."


    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
      h2_ "Maps"
      flip M.foldMapWithKey dirresultMaps $ \name MapResult { .. } -> do
        h3_ (toHtml name)
        if null mapresultGeneral && null mapresultLayer && null mapresultTileset
        then ul_ $ li_ $ badgeHurray "All good!"
        else do
          ul_ $ forM_ mapresultGeneral $ \lint ->
            li_ (toHtml lint)
          unless (null mapresultLayer) $ do
            h4_ "Layers"
            ul_ (listMapWithKey mapresultLayer)
          unless (null mapresultTileset) $ do
            h4_ "Tilesets"
            ul_ (listMapWithKey mapresultTileset)

    where
      maxlevel = maximumLintLevel res

      placeList :: (Monad m, ToHtml h) => [h] -> 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; ")"