summaryrefslogtreecommitdiff
path: root/server/HtmlOrphans.hs
blob: 947504562a94a09db01e522d785d8640a7a8a1cc (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
{-# 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, button_, onclick_)
import           Lucid.Base      (ToHtml (toHtml))
import           Lucid.Html5     (a_, body_, class_, code_, div_, em_, h1_, h2_,
                                  h3_, h4_, h5_, head_, href_, html_, id_, li_,
                                  link_, main_, 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)"
      Linted res _rev -> do
        h1_ "Linter Result"
        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\
          \    let btn = document.getElementById('relint_button');\n\
          \    btn.innerText = 'pending … (please reload)';\n\
          \    btn.disabled = true;\n\
          \    btn.class = 'btn btn-disabled';\n\
          \  }}\n\
          \  xhr.send(null);\n\
          \}"
      Failed err -> do
        h1_ "System Error"
        p_ $ "error: " <> toHtml err
        p_ "you should probably ping an admin about this or sth"

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