{-# 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 #-}
{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE FlexibleInstances #-}

-- | 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 qualified Data.Text       as T
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_, 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 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; ")"