diff options
| -rw-r--r-- | lib/CheckDir.hs | 3 | ||||
| -rw-r--r-- | package.yaml | 3 | ||||
| -rw-r--r-- | server/Main.hs | 25 | ||||
| -rw-r--r-- | server/Orphans.hs | 57 | ||||
| -rw-r--r-- | server/Server.hs | 21 | ||||
| -rw-r--r-- | stack.yaml | 2 | ||||
| -rw-r--r-- | stack.yaml.lock | 7 | ||||
| -rw-r--r-- | walint.cabal | 5 |
8 files changed, 111 insertions, 12 deletions
diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs index f876084..eeb94a8 100644 --- a/lib/CheckDir.hs +++ b/lib/CheckDir.hs @@ -7,7 +7,7 @@ {-# LANGUAGE TypeFamilies #-} -- | Module that contains high-level checking for an entire directory -module CheckDir (recursiveCheckDir, DirResult(..), resultIsFatal) where +module CheckDir (maximumLintLevel, recursiveCheckDir, DirResult(..), MissingAsset(..), MissingDep(..), resultIsFatal) where import CheckMap (MapResult (..), loadAndLintMap) import Control.Monad (void) @@ -38,7 +38,6 @@ import Types (Dep (Local, LocalMap), Hint (Hint), Level (..), hintLevel) import Util (PrettyPrint (prettyprint), ellipsis) - -- based on the startling observation that Data.Map has lower complexity -- for difference than Data.Set, but the same complexity for fromList type Set a = Map a () diff --git a/package.yaml b/package.yaml index a4681bc..6a3abc0 100644 --- a/package.yaml +++ b/package.yaml @@ -34,6 +34,7 @@ library: - HList exposed-modules: - CheckDir + - CheckMap - WriteRepo - Util - Types @@ -74,3 +75,5 @@ executables: - microlens - microlens-th - tomland + - lucid + - servant-lucid diff --git a/server/Main.hs b/server/Main.hs index 0fbc4b4..00b4689 100644 --- a/server/Main.hs +++ b/server/Main.hs @@ -22,14 +22,15 @@ import Network.Wai.Handler.Warp (run) import Servant (Application, Capture, Get, Handler, HasServer (ServerT), JSON, NoContent, Post, Proxy (Proxy), - ReqBody, ServerError (errBody), - err500, hoistServer, serve, - throwError, type (:<|>) (..), - type (:>)) + Raw, ReqBody, + ServerError (errBody), err500, + hoistServer, serve, throwError, + type (:<|>) (..), type (:>)) +import Servant.HTML.Lucid (HTML) +import Servant.Server.StaticFiles (serveDirectoryWebApp) import Server (Config (..), JobStatus, RemoteRef (..), State, defaultState, loadConfig) - {- Needed: - admin overview (perhaps on seperate port?) @@ -48,6 +49,10 @@ type API format = :<|> "status" :> Capture "jobid" UUID :> Get '[format] JobStatus :<|> "relint" :> Capture "jobid" UUID :> Get '[format] NoContent +type Routes = + "api" :> API JSON + :<|> "status" :> Capture "jobid" UUID :> Get '[HTML] JobStatus + :<|> Raw -- | API's implementation jsonAPI :: Config True -> MVar State -> ServerT (API JSON) App @@ -56,11 +61,17 @@ jsonAPI config state = :<|> statusImpl state :<|> relintImpl config state +server :: Config True -> MVar State -> ServerT Routes App +server config state = + jsonAPI config state + :<|> statusImpl state + :<|> serveDirectoryWebApp "./static" + -- | make an application; convert any cli errors into a 500 app :: Config True -> MVar State -> Application app config = - serve api . hoistServer api conv . jsonAPI config - where api = Proxy @(API JSON) + serve api . hoistServer api conv . server config + where api = Proxy @Routes conv :: App a -> Handler a conv m = do config <- liftIO $ mkDefaultCliConfig [] diff --git a/server/Orphans.hs b/server/Orphans.hs new file mode 100644 index 0000000..b46f728 --- /dev/null +++ b/server/Orphans.hs @@ -0,0 +1,57 @@ + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + + +module Orphans where + + +import Control.Monad (forM_, unless) +import qualified Data.Map as M +import Data.Text (Text) +import Lucid (ToHtml) +import Lucid.Base (ToHtml (toHtml)) +import Lucid.Html5 + +import CheckDir +import CheckMap +import Types +import Util (prettyprint) + +instance ToHtml Hint where + toHtml (Hint l m) = do + span_ [class_ "level"] $ toHtml (show l) + toHtml m + + +instance ToHtml DirResult where + toHtml res@DirResult { .. } = do + h3_ $ toHtml (show $ maximumLintLevel res) + unless (null dirresultMissingAssets && null dirresultDeps) $ do + h2_ "Dependencies" + ul_ $ do + forM_ dirresultMissingAssets $ \(MissingAsset missing) -> do + li_ $ toHtml (prettyprint missing) + forM_ dirresultDeps $ \missing -> do + li_ $ toHtml (prettyprint missing) + unless (null dirresultMaps) $ do + h2_ "Maps" + flip M.foldMapWithKey dirresultMaps $ \name MapResult { .. } -> do + h3_ (toHtml name) + ul_ $ do + forM_ mapresultGeneral $ \lint -> + li_ (toHtml lint) + flip M.foldMapWithKey mapresultLayer $ \lint layers -> + li_ $ do + toHtml lint + toHtml ("(in layer" :: Text) + forM_ layers $ \layer -> + span_ [class_ "layer"] (toHtml layer) + toHtml (")" :: Text) + flip M.foldMapWithKey mapresultTileset $ \lint tilesets -> + li_ $ do + toHtml lint + toHtml ("( in layer" :: Text) + forM_ tilesets $ \tileset -> + span_ [class_ "tileset"] (toHtml tileset) + toHtml (")" :: Text) diff --git a/server/Server.hs b/server/Server.hs index a5a820a..536350f 100644 --- a/server/Server.hs +++ b/server/Server.hs @@ -27,12 +27,14 @@ import GHC.Generics (Generic) import Lens.Micro (over) import Lens.Micro.TH import LintConfig (LintConfig') +import Lucid (ToHtml (..)) +import Lucid.Html5 +import Orphans () import System.Exit.Compat (exitFailure) import Toml (TomlCodec) import qualified Toml import Toml.Codec ((.=)) - -- | a reference in a remote git repository data RemoteRef = RemoteRef { repourl :: Text @@ -69,6 +71,23 @@ data State = State , _registry :: Map UUID RemoteRef } +instance ToHtml JobStatus where + toHtml status = html_ $ do + head_ $ do + title_ "Job Status" + link_ [rel_ "stylesheet", type_ "text/css", href_ "/styles.css"] + body_ $ div_ [class_ "main-content"] $ case status of + Pending -> do + h2_ "Pending …" + p_ "(please note that this site won't auto-reload, you'll have to refresh it yourself)" + Linted res -> do + p_ "Linted" + toHtml res + Failed err -> do + h2_ "System Error" + p_ $ "error: " <> toHtml err + p_ "you should probably ping an admin about this or sth" + makeLenses ''State defaultState :: State @@ -27,7 +27,7 @@ extra-deps: - logging-effect-1.3.12@sha256:72d168dd09887649ba9501627219b6027cbec2d5541931555b7885b133785ce3,1679 - which-0.2@sha256:db82ca7d83d64cce8ad579756f02d27c5bd289806ee02474726f7fafb87318e8,858 - cli-git-0.1.0.2@sha256:4e62e6b7357e4fe698df8b58ba53919f9d4a056e9617dbc00c869a365e316387,1122 - + - servant-lucid-0.9.0.4@sha256:698db96903a145fdef40cc897f8790728642af917c37b941a98b2da872b65f08,1787 allow-newer: true # use aeson with a non-hash-floodable implementation diff --git a/stack.yaml.lock b/stack.yaml.lock index a7bbaf3..93443e4 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -74,6 +74,13 @@ packages: sha256: 1e81c51e2b60db2b1784901cf0af33c67384f5412ad8edaad8a7068135f5217f original: hackage: cli-git-0.1.0.2@sha256:4e62e6b7357e4fe698df8b58ba53919f9d4a056e9617dbc00c869a365e316387,1122 +- completed: + hackage: servant-lucid-0.9.0.4@sha256:698db96903a145fdef40cc897f8790728642af917c37b941a98b2da872b65f08,1787 + pantry-tree: + size: 392 + sha256: 39e0e7b2b25980bfe4df036e89959188f9ef9e8c78c85e241fa9a682d1d78cf3 + original: + hackage: servant-lucid-0.9.0.4@sha256:698db96903a145fdef40cc897f8790728642af917c37b941a98b2da872b65f08,1787 snapshots: - completed: size: 586286 diff --git a/walint.cabal b/walint.cabal index b9982d1..1129e23 100644 --- a/walint.cabal +++ b/walint.cabal @@ -15,13 +15,13 @@ build-type: Simple library exposed-modules: CheckDir + CheckMap WriteRepo Util Types LintConfig other-modules: Badges - CheckMap Dirgraph KindLinter LayerData @@ -61,6 +61,7 @@ executable server main-is: Main.hs other-modules: Handlers + Orphans Server Paths_walint hs-source-dirs: @@ -79,11 +80,13 @@ executable server , filepath , http-media , logging-effect + , lucid , microlens , microlens-th , mtl , process , servant + , servant-lucid , servant-server , string-conversions , text |