.gitignore

 dist-newstyle/*
 .stack-work
+walint.cabal
+result*

Readme.md

 # walint: lint & adjust workadventure maps
 
-`walint` is intended as a simple linter that will check workadventure maps for
-common errors, such as non-existent map entrypoints or missing asset files, and
-additionally suggest changes to improve accessability.
+### Overview & Components
 
-Optionally, it can also *adjust* maps — e.g. to automatically insert property 
-values or help enforce an event's map policies — and then write them out again,
-copying all needed assets and minifying the map's json. This is used to simulate
-a `bbbRoom` property (via `openWebsite`), collect and remove badge tokens before
-maps are published, and to resolve special-schema URIs (e.g. `world://`).
+`walint` is intended as a linter for workadventure maps that checks for common
+errors (such as non-existent map entrypoints or missing asset files) and makes
+suggestions to improve accessability.
+
+It can also *adjust* maps — e.g. to automatically insert property values or help
+enforce an event's map policies (among other things, this is used to resolve 
+special inter-assembly `world://` links).
+
+`walint-mapserver` is a minimal implementation of a server that periodically
+fetches, lints, and adjusts maps from a set of git repositories, writing them
+to a path that can then be served by a webserver. It can be used as a (very
+simple) replacement for rc3's hub and mapservice at smaller events.
+
+`cwality-maps` is a small server for type-safe map templating, to be used if
+maps need to be generated on-the-fly — for example, to provide custom intermediate
+maps displaying CWs before another map can be reached.
 
 ## Installing
 
@@ -25,7 +34,7 @@ running `ldd walint` and see if anything is marked as not found, then install it
 ### Build using stack
 
 This uses a lockfile to pin versions of dependencies (as well as `ghc`, the haskell
-compiler). You will need [stack](https://docs.haskellstack.org/en/stable/README/).
+compiler). You will need [the haskell stack](https://docs.haskellstack.org/en/stable/README/).
 
 Then just run
 
@@ -34,8 +43,8 @@ stack build
 ```
 
 If you lack `ghc` in the correct version and don't know how to install it, you can
-pass it `--install-ghc` to take care of that for you (note that on Nix, `stack` may
-automatically use a fitting `ghc` derivation if it finds one).
+pass it `--install-ghc` to take care of that for you (note that on NixOS, `stack` may
+use a fitting `ghc` derivation if it finds one, even without `--install-ghc`).
 
 To install into your `$PATH`, use
 
@@ -50,25 +59,11 @@ stack run -- walint [options as normal]
 ```
 
 However, in this case stack will re-check files every time to ensure your build
-is up to date with the sources, which will make it slower to start.
+is up to date with the sources, increasing startup time.
 
 ### Build using cabal
 
-Note that this does not pin dependencies, and `walint` currently does not even
-define semver ranges to ensure it compiles at all! Even so, you can use 
-[cabal](https://www.haskell.org/cabal/) if for some reason you absolutely must,
-as long as your package list is sufficiently recent.
-
-Run:
-
-```
-cabal update
-cabal build
-```
-
-Note that `cabal` might decide to pull in an older version of Aeson which is
-still vulnerable to hash flooding; in that case `walint` will print a warning
-on startup.
+You can, but probably should not. Beware of older Aeson versions!
 
 ## Usage
 ``` sh
@@ -136,10 +131,8 @@ For now there are three types of such rules:
 In case an URI is encountered and there is no applicable rule, it will be rejected
 (note that this means you'll have to explicitly allow `https://` for links!)
 
-There are currently four possible scopes: `map` applies to tiled map links 
-(i.e. `exitUrl`), `website` to `openWebsite`, `audio` to `playAudio`, and
-`bbb` to Big Blue Button rooms (though that last one may be changed again,
-depending on the bbb deployment in use).
+There are currently three possible scopes: `map` applies to tiled map links 
+(i.e. `exitUrl`), `website` to `openWebsite`, `audio` to `playAudio`.
 
 
 ## Output

config.json

@@ -5,21 +5,14 @@
   "AllowScripts":false,
   "MaxLintLevel":"Warning",
   "DontCopyAssets":false,
-  "UriSchemas": [
-    ["https", {
-      "scope" : ["website"],
-      "allowed" : ["media.ccc.de", "streaming.media.ccc.de", "static.rc3.world", "cdn.c3voc.de", "pretalx.c3voc.de"],
-      "blocked" : ["blocked.com"],
-      "prefix" : "https:\/\/rc3.world\/2021\/wa_dereferrer\/"
-    }],
-    ["https", {
-      "scope" : ["audio"],
-      "allowed" : ["cdn.c3voc.de", "media.ccc.de", "streaming.media.ccc.de", "static.rc3.world", "live.dort.c3voc.de"]
-    }],
-    ["world", {
-      "scope" : ["map"],
-      "substs" : {
-      }
-    }]
-  ]
+  "UriSchemas": {
+    "https:": [
+      {
+        "scope" : [ "website", "audio" ]
+      },
+      {
+        "scope" : [ "script" ],
+        "allowed" : [ "scripts.world.di.c3voc.de" ]
+      }]
+  }
 }

config.toml

+
+
+port = 8080
+verbose = true
+
+tmpdir = "/tmp"
+
+# linting interval in seconds
+interval = 36000
+
+# where to post map updates to
+# exneuland = "http://localhost:4000"
+# auth token for map updates
+token = "hello, world!"
+
+[[org]]
+slug = "divoc"
+
+# baseurl of maps as seen by the frontend
+url = "https://world.di.c3voc.de/maps/"
+# webdir into which maps should be written
+webdir = "/tmp/var/www/divoc"
+
+# increment this if you change the server / linter config
+# (part of urls for linted maps; allows indefinite browser caching)
+generation = 1
+
+backlink_prefix = "world://lobby#start_"
+contact_mail = "world@muc.hacc.space"
+howto_link = "https://di.c3voc.de/howto:world"
+
+# linter's config for this org
+lintconfig = "./config.json"
+# map's entrypoint (only maps reachable from here are included)
+entrypoint = "main.json"
+
+[[org.repo]] # I hate TOML
+url = "https://gitlab.infra4future.de/hacc/events/hacc-map"
+ref = "master"
+name = "hacc"
+
+[[org.repo]]
+url = "https://github.com/namiko/assembly_2021"
+ref = "master"
+name = "haecksen"

cwality-config.toml

+
+
+verbose = true
+port = 8080
+
+# directory containing template maps.
+# all .json files therein will be interpreted as maps;
+# other files are served statically
+template = "./example-templates"

cwality-maps/Config.hs

+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE KindSignatures    #-}
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE TupleSections     #-}
+{-# LANGUAGE TypeFamilies      #-}
+
+module Config ( loadConfig
+              , Config, port, verbose, template
+              ) where
+
+import           Universum
+
+import           Data.List           (isSuffixOf)
+import qualified Data.Map.Strict     as M
+import           Data.Tiled          (Tiledmap,
+                                      loadTiledmap)
+import           Lens.Micro.Platform (makeLenses, traverseOf)
+import           System.Directory    (listDirectory)
+import           System.FilePath     ((</>))
+import           Toml                (TomlCodec, (.=))
+import qualified Toml                as T
+
+type family ConfigRes (b :: Bool) a where
+  ConfigRes True a = a
+  ConfigRes False a = FilePath
+
+-- | the server's configuration
+data Config (loaded :: Bool) = Config
+  { _port     :: Int
+  , _verbose  :: Bool
+  , _template :: ConfigRes loaded (FilePath, Map Text Tiledmap)
+  } deriving Generic
+
+makeLenses ''Config
+
+
+configCodec :: TomlCodec (Config False)
+configCodec = Config
+    <$> T.int "port" .= _port
+    <*> T.bool "verbose" .= _verbose
+    <*> T.string "template" .= _template
+
+loadConfig :: FilePath -> IO (Config True)
+loadConfig path = do
+  T.decodeFileEither configCodec path >>= \case
+    Right c  -> traverseOf template loadMaps c
+    Left err -> error (show err)
+    where loadMaps path = do
+            maps <- listDirectory path
+              <&> filter (".json" `isSuffixOf`)
+
+            list <- forM maps $ \mapname ->
+              loadTiledmap (path </> mapname) >>= \case
+                Right tmap -> pure (toText mapname, tmap)
+                err         -> error (show err)
+
+            pure (path, M.fromList list)

cwality-maps/Main.hs

+{-# LANGUAGE DataKinds            #-}
+{-# LANGUAGE DeriveAnyClass       #-}
+{-# LANGUAGE DeriveGeneric        #-}
+{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE RankNTypes           #-}
+{-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE TupleSections        #-}
+{-# LANGUAGE TypeApplications     #-}
+{-# LANGUAGE TypeFamilies         #-}
+{-# LANGUAGE TypeOperators        #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+
+-- | simple server offering linting "as a service"
+module Main where
+
+import           Universum
+
+import           Config                               (Config, loadConfig, port,
+                                                       template, verbose)
+import           Data.Aeson                           (FromJSON)
+import qualified Data.Aeson                           as A
+import qualified Data.Map.Strict                      as M
+import qualified Data.Text                            as T
+import           Data.Text.Encoding.Base64.URL        (decodeBase64Unpadded)
+import           Data.Tiled                           (Tiledmap)
+import           Network.Wai.Handler.Warp             (defaultSettings,
+                                                       runSettings, setPort)
+import           Network.Wai.Middleware.Gzip          (def)
+import           Network.Wai.Middleware.RequestLogger (OutputFormat (..),
+                                                       RequestLoggerSettings (..),
+                                                       mkRequestLogger)
+import           Servant                              (Application, Capture,
+                                                       CaptureAll,
+                                                       FromHttpApiData (parseUrlPiece),
+                                                       Get, Handler, JSON, Raw,
+                                                       Server, err400, err404,
+                                                       serve, throwError,
+                                                       type (:<|>) (..),
+                                                       type (:>))
+import           Servant.Server.StaticFiles           (serveDirectoryWebApp)
+import           Substitute                           (Substitutable (substitute),
+                                                       SubstitutionError)
+
+import           Control.Monad.Logger
+
+
+-- | a map's filename ending in .json
+-- (a newtype to differentiate between maps and assets in a route)
+newtype JsonFilename = JsonFilename Text
+
+instance FromHttpApiData JsonFilename where
+  parseUrlPiece url =
+    if ".json" `T.isSuffixOf` url
+    then Right (JsonFilename url)
+    else Left url
+
+
+newtype Tag = Tag Text
+  deriving (Generic, FromJSON)
+
+newtype MapParams = MapParams
+  { substs          :: Map Text Text
+  } deriving (Generic, FromJSON)
+
+instance FromHttpApiData MapParams where
+  parseUrlPiece urltext =
+    case decodeBase64Unpadded urltext of
+    Right text -> case A.decode (encodeUtf8 text) of
+      Just params -> params
+      Nothing     -> Left "decoding params failed?"
+    -- for fun (and testing) also allow non-encoded json
+    Left _err -> case A.decode (encodeUtf8 urltext) of
+      Just params -> Right params
+      Nothing     ->  Left "decoding MapParams failed"
+
+-- | actual set of routes: api for json & html + static pages from disk
+type Routes =
+  "generate" :> Capture "params" MapParams :>
+    (Capture "map.json" JsonFilename :> Get '[JSON] Tiledmap
+    -- explicitly capture broken json to return 400 instead of looking for files
+    :<|> Capture "map.json" JsonFilename :> CaptureAll "rest" Text :> Get '[JSON] Void
+    :<|> Raw)
+
+
+
+
+mkMap :: Config True -> Tiledmap -> MapParams -> ([SubstitutionError], Tiledmap)
+mkMap _config basemap params =
+  substitute basemap (substs params)
+
+mapHandler :: MapParams -> Config True -> JsonFilename -> Handler Tiledmap
+mapHandler params config (JsonFilename mapname) =
+  case M.lookup mapname (snd $ view template config) of
+    Just basemap -> runStdoutLoggingT $
+      logWarnN (pretty errors) >> pure tiledmap
+      where (errors, tiledmap) = mkMap config basemap params
+            pretty errors = T.concat
+              . intersperse "\n  "
+              $ concatMap (lines . show) errors
+    Nothing      -> throwError err404
+
+-- | Complete set of routes: API + HTML sites
+server :: Config True -> Server Routes
+server config params =
+               mapHandler params config
+          :<|> (\_ _ -> throwError err400)
+          :<|> serveDirectoryWebApp (fst . view template $ config)
+
+app :: Config True -> Application
+app = serve (Proxy @Routes) . server
+
+
+
+main :: IO ()
+main = do
+  config <- loadConfig "./cwality-config.toml"
+  loggerMiddleware <- mkRequestLogger
+    $ def { outputFormat = Detailed (view verbose config) }
+
+  let warpsettings =
+       setPort (view port config)
+       defaultSettings
+
+  runSettings warpsettings
+    . loggerMiddleware
+    $ app config

cwality-maps/Substitute.hs

+{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE RankNTypes           #-}
+{-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE TupleSections        #-}
+{-# LANGUAGE TypeFamilies         #-}
+{-# LANGUAGE TypeOperators        #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- | Typeclasses for (generic) substitution on all strings contained in an ADT,
+-- failsafe, but with error reporting
+module Substitute (SubstitutionError, Substitutable(..)) where
+
+import           Universum
+
+import qualified Data.Aeson           as A
+import qualified Data.Foldable        as Fold
+import           Data.Tiled           (GlobalId, LocalId)
+import           GHC.Generics         (Generic (Rep, from, to), K1 (K1),
+                                       M1 (M1), U1, type (:*:) ((:*:)),
+                                       type (:+:) (..))
+import qualified Text.Mustache        as MU
+import qualified Text.Mustache.Render as MU
+import           Text.Parsec.Error    (ParseError)
+
+-- | errors that might be encountered. SubstitutionErrors occur during substitution
+-- and a generally non-fatal (but might result e.g. in empty strings being inserted
+-- instead of variables), while CompileErrors may indicate that (invalid) template
+-- syntax got leaked into the output
+data SubstitutionError = CompileError ParseError  | Mustache MU.SubstitutionError
+  deriving Show
+
+
+class Substitutable s where
+  substitute :: s -> Map Text Text -> ([SubstitutionError], s)
+
+instance Substitutable Text where
+  substitute orig substs = case MU.compileTemplate "" orig of
+    Right template -> first (map Mustache) $ MU.checkedSubstitute template substs
+    Left err -> ([CompileError err], orig) -- just ignore syntactic errors (TODO: add a log message?)
+
+
+instance {-# OVERLAPS #-} Substitutable String where
+  substitute orig substs = second toString (substitute (toText orig) substs)
+
+instance {-# OVERLAPPING #-} (Functor a, Substitutable b, Foldable a) => Substitutable (a b) where
+  substitute orig substs = (Fold.fold $ map fst orig',) $ map snd orig'
+    where orig' = map (`substitute` substs) orig
+
+-- | helper: don't substitute anything, don't produce errors
+trivial :: t -> b -> ([a], t)
+trivial = const . ([],)
+
+instance {-# OVERLAPS #-} Substitutable A.Value where
+  substitute (A.Object fields) params =
+    second A.Object $ traverse (`substitute` params) fields
+  substitute (A.String str) params =
+    second A.String $ substitute str params
+  substitute other params = ([], other)
+
+
+instance Substitutable Int where
+  substitute = trivial
+
+instance Substitutable GlobalId where
+  substitute = trivial
+
+instance Substitutable LocalId where
+  substitute = trivial
+
+instance Substitutable Double where
+  substitute = trivial
+
+instance Substitutable Float where
+  substitute = trivial
+
+class GSubstitutable i where
+  gsubstitute :: i p -> Map Text Text -> ([SubstitutionError], i p)
+
+instance Substitutable c => GSubstitutable (K1 i c) where
+  gsubstitute (K1 text) = second K1 . substitute text
+
+instance (GSubstitutable a, GSubstitutable b) => GSubstitutable (a :*: b) where
+  gsubstitute (a :*: b) substs = (e1 <> e2, a' :*: b')
+    where (e1, a') = gsubstitute a substs
+          (e2, b') = gsubstitute b substs
+
+instance (GSubstitutable a, GSubstitutable b) => GSubstitutable (a :+: b) where
+  gsubstitute (L1 a) = second L1 . gsubstitute a
+  gsubstitute (R1 a) = second R1 . gsubstitute a
+
+instance (GSubstitutable a) => GSubstitutable (M1 x y a) where
+  gsubstitute (M1 a) = second M1 . gsubstitute a
+
+instance GSubstitutable U1 where
+  gsubstitute = trivial
+
+instance {-# OVERLAPPABLE #-} (GSubstitutable (Rep a), Generic a) => Substitutable a where
+  substitute a substs = second to (gsubstitute (from a) substs)

default.nix

+let
+  sources = import ./nix/sources.nix {};
+  haskellNix = import sources.haskellNix {};
+
+  # Import nixpkgs and pass the haskell.nix provided nixpkgsArgs
+  pkgs = import
+    # use haskell.nix's nixpkgs, which may (?) have more substitutes available
+    haskellNix.sources.nixpkgs-unstable
+    # args for nixpkgs; includes the haskell.nix overlay
+    (haskellNix.nixpkgsArgs // { system = "x86_64-linux"; });
+
+  drvs = pkgs.haskell-nix.project {
+   # 'cleanGit' cleans a source directory based on the files known by git
+   src = pkgs.haskell-nix.haskellLib.cleanGit {
+     src = ./.;
+     name = "walint";
+   };
+   modules = [{
+     packages.walint.components.exes = {
+       # don't include gcc or ghc in the dependency closure …
+       walint-server.dontStrip = false;
+       walint.dontStrip = false;
+     };
+   }];
+   stack-sha256 = "0bp3dwj2kl6n0swz5yf9kjy5ahp6i5qrnb39hkrsqgf0682i9nk1";
+  };
+in
+{
+  walint = drvs.walint.components.exes.walint;
+  walint-server = pkgs.stdenvNoCC.mkDerivation {
+    name = "walint-server-with-assets";
+    src = drvs.walint.components.exes.walint-mapserver;
+    phases = [ "buildPhase" ];
+    buildPhase = ''
+      mkdir -p $out
+      cp -r $src/* $out
+      cp -r ${pkgs.copyPathToStore ./static} $out/static
+      cp ${pkgs.copyPathToStore ./config.json} $out/config.json
+      cp ${pkgs.copyPathToStore ./config.toml} $out/config.toml
+    '';
+  };
+}

fixed.nix

+{ nixpkgs ? import <nixpkgs> {} }:
+with nixpkgs;
+
+stdenv.mkDerivation {
+  name = "walint-fixed";
+
+  buildInputs = [ ghc stack zlib zlib.dev git openssl cacert ];
+
+  src = ./.;
+
+  buildPhase = ''
+    cp -r $src .
+    mkdir /tmp/stack-home
+    HOME=/tmp/stack-home stack build --no-nix --system-ghc
+  '';
+
+  installPhase = ''
+    HOME=/tmp/stack-home stack install --local-bin-path $out --no-nix --system-ghc
+    mkdir -p $out/share/walint
+    cp -r static $out/share/walint
+    cp config.json $out/share/walint
+    cp config.toml $out/share/walint
+  '';
+
+  outputHashAlgo = "sha256";
+  outputHashMode = "recursive";
+  # replace this with the correct SHA256
+  outputHash = "sha256-Qd7MDGslrS6zs6WWI9sjzDous0nUbrjdK2fF747KLq8=";
+  dontShrink = true;
+}

lib/Badges.hs

-{-# LANGUAGE DeriveAnyClass    #-}
-{-# LANGUAGE DeriveGeneric     #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE DeriveAnyClass             #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE RecordWildCards            #-}
 
 -- | module defining Badge types and utility functions
 module Badges where
 
+import           Universum
+
 import           Data.Aeson      (Options (fieldLabelModifier, sumEncoding),
                                   SumEncoding (UntaggedValue), ToJSON (toJSON),
                                   defaultOptions, genericToJSON, (.=))
 import qualified Data.Aeson      as A
 import           Data.Char       (toLower)
-import           Data.Text       (Text)
-import           GHC.Generics    (Generic)
 import           Text.Regex.TDFA ((=~))
 
 
@@ -27,10 +29,10 @@ data BadgeArea =
    , areaWidth  :: Double
    , areaHeight :: Double
    }
-  deriving (Ord, Eq, Generic, Show)
+  deriving (Ord, Eq, Generic, Show, NFData)
 
 newtype BadgeToken = BadgeToken Text
-  deriving (Eq, Ord, Show)
+  deriving newtype (Eq, Ord, Show, NFData)
 
 instance ToJSON BadgeArea where
   toJSON = genericToJSON defaultOptions
@@ -46,7 +48,7 @@ parseToken text = if text =~ ("^[a-zA-Z0-9]{50}$" :: Text)
   else Nothing
 
 data Badge = Badge BadgeToken BadgeArea
-  deriving (Ord, Eq, Generic, Show)
+  deriving (Ord, Eq, Generic, Show, NFData)
 
 instance ToJSON Badge where
   toJSON (Badge token area) = A.object $ case area of

lib/CheckDir.hs

-{-# LANGUAGE DeriveAnyClass    #-}
-{-# LANGUAGE DeriveGeneric     #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE LambdaCase        #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TupleSections     #-}
-{-# LANGUAGE TypeFamilies      #-}
+{-# LANGUAGE BangPatterns         #-}
+{-# LANGUAGE DataKinds            #-}
+{-# LANGUAGE DeriveAnyClass       #-}
+{-# LANGUAGE DeriveGeneric        #-}
+{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE LambdaCase           #-}
+{-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE TupleSections        #-}
+{-# LANGUAGE TypeFamilies         #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 -- | Module that contains high-level checking for an entire directory
-module CheckDir (recursiveCheckDir, DirResult(..), resultIsFatal)  where
-
-import           CheckMap               (MapResult (..), loadAndLintMap)
-import           Control.Monad          (void)
+module CheckDir ( maximumLintLevel
+                , recursiveCheckDir
+                , DirResult (..)
+                , MissingAsset(..)
+                , MissingDep(..)
+                , resultIsFatal
+                ,shrinkDirResult)  where
+
+import           Universum              hiding (Set)
+
+import           CheckMap               (MapResult (..), Optional,
+                                         ResultKind (..), loadAndLintMap,
+                                         shrinkMapResult)
 import           Control.Monad.Extra    (mapMaybeM)
 import           Data.Aeson             (ToJSON, (.=))
 import qualified Data.Aeson             as A
-import           Data.Bifunctor         (first)
-import           Data.Foldable          (fold)
-import           Data.Functor           ((<&>))
 import           Data.List              (partition)
-import           Data.Map               (Map, elems, keys)
 import qualified Data.Map               as M
 import           Data.Map.Strict        (mapKeys, mapWithKey, (\\))
-import           Data.Maybe             (isJust, mapMaybe)
-import           Data.Text              (Text, isInfixOf)
+import           Data.Text              (isInfixOf)
 import qualified Data.Text              as T
+import           Data.Tiled             (Tiledmap)
 import           Dirgraph               (graphToDot, invertGraph, resultToGraph,
                                          takeSubGraph, unreachableFrom)
 import           GHC.Generics           (Generic)
@@ -33,7 +42,7 @@ import           System.Directory.Extra (doesFileExist)
 import           System.FilePath        (splitPath, (</>))
 import qualified System.FilePath        as FP
 import           System.FilePath.Posix  (takeDirectory)
-import           Text.Dot               (Dot, showDot)
+import           Text.Dot               (showDot)
 import           Types                  (Dep (Local, LocalMap), Hint (Hint),
                                          Level (..), hintLevel)
 import           Util                   (PrettyPrint (prettyprint), ellipsis)
@@ -48,29 +57,39 @@ listFromSet :: Set a -> [a]
 listFromSet = map fst . M.toList
 
 -- | Result of linting an entire directory / repository
-data DirResult = DirResult
-  { dirresultMaps          :: Map FilePath MapResult
+data DirResult (complete :: ResultKind) = DirResult
+  { dirresultMaps          :: Map FilePath (MapResult complete)
   -- ^ all maps of this respository, by (local) filepath
   , dirresultDeps          :: [MissingDep]
   -- ^ all dependencies to things outside this repository
   , dirresultMissingAssets :: [MissingAsset]
   -- ^ entrypoints of maps which are referred to but missing
-  , dirresultGraph         :: Dot ()
+  , dirresultGraph         :: Text
   } deriving (Generic)
 
+instance NFData (Optional a (Maybe Tiledmap)) => NFData (DirResult a)
+
+
 data MissingDep = MissingDep
   { depFatal   :: Maybe Bool
   , entrypoint :: Text
   , neededBy   :: [FilePath]
-  } deriving (Generic, ToJSON)
+  } deriving (Generic, ToJSON, NFData)
 
 -- | Missing assets are the same thing as missing dependencies,
 -- but should not be confused (and also serialise differently
 -- to json)
 newtype MissingAsset = MissingAsset MissingDep
+  deriving (Generic, NFData)
+
+
+-- | "shrink" the result by throwing the adjusted tiledmaps away
+shrinkDirResult :: DirResult Full -> DirResult Shrunk
+shrinkDirResult !res =
+  res { dirresultMaps = fmap shrinkMapResult (dirresultMaps res) }
 
 -- | given this config, should the result be considered to have failed?
-resultIsFatal :: LintConfig' -> DirResult -> Bool
+resultIsFatal :: LintConfig' -> DirResult Full -> Bool
 resultIsFatal config res =
   not (null (dirresultMissingAssets res) || not (any (isJust . depFatal) (dirresultDeps res)))
   || maximumLintLevel res > configMaxLintLevel config
@@ -78,11 +97,11 @@ resultIsFatal config res =
 -- | maximum lint level that was observed anywhere in any map.
 -- note that it really does go through all lints, so don't
 -- call it too often
-maximumLintLevel :: DirResult -> Level
+maximumLintLevel :: DirResult a -> Level
 maximumLintLevel res
   | not (null (dirresultMissingAssets res)) = Fatal
   | otherwise =
-    (\t -> if null t then Info else maximum t)
+    (maybe Info maximum . nonEmpty)
     . map hintLevel
     . concatMap (\map -> keys (mapresultLayer map)
                   <> keys (mapresultTileset map)
@@ -94,7 +113,7 @@ maximumLintLevel res
 
 
 
-instance ToJSON DirResult where
+instance ToJSON (DirResult a) where
   toJSON res = A.object [
     "result" .=  A.object
       [ "missingDeps" .= dirresultDeps res
@@ -106,8 +125,7 @@ instance ToJSON DirResult where
                        . foldr aggregateSameResults []
                        . M.toList
                        $ dirresultMaps res)
-      -- unused in the hub, temporarily removed to make the output smaller
-      , "exitGraph" .= showDot (dirresultGraph res)
+      , "exitGraph" .= dirresultGraph res
       ]
     , "severity" .= maximumLintLevel res
     , "mapInfo" .= fmap (\tm -> A.object [ "badges" .= mapresultBadges tm ])
@@ -116,8 +134,8 @@ instance ToJSON DirResult where
     where
       aggregateSameResults (path,res) acc =
         case partition (\(_,res') -> res == res') acc of
-          ([],_)             -> ([T.pack path], res):acc
-          ((paths,_):_,acc') -> (T.pack path:paths, res) : acc'
+          ([],_)             -> ([toText path], res):acc
+          ((paths,_):_,acc') -> (toText path:paths, res) : acc'
 
 instance ToJSON MissingAsset where
   toJSON (MissingAsset md) = A.object
@@ -126,7 +144,7 @@ instance ToJSON MissingAsset where
     ]
 
 
-instance PrettyPrint (Level, DirResult) where
+instance PrettyPrint (Level, DirResult a) where
   prettyprint (level, res) = prettyMapLints <> prettyMissingDeps
     where
       prettyMissingDeps = if not (null (dirresultDeps res))
@@ -134,9 +152,9 @@ instance PrettyPrint (Level, DirResult) where
         else ""
       prettyMapLints = T.concat
         (map prettyLint $ M.toList $ dirresultMaps res)
-      prettyLint :: (FilePath, MapResult) -> Text
+      prettyLint :: (FilePath, MapResult a) -> Text
       prettyLint (p, lint) =
-        "\nin " <> T.pack p <> ":\n" <> prettyprint (level, lint)
+        "\nin " <> toText p <> ":\n" <> prettyprint (level, lint)
 
 instance PrettyPrint MissingDep where
   prettyprint (MissingDep _ f n) =
@@ -144,7 +162,7 @@ instance PrettyPrint MissingDep where
     <> prettyDependents <> "\n"
     where
       prettyDependents =
-        T.intercalate "," $ map T.pack n
+        T.intercalate "," $ map toText n
 
 
 -- | check an entire repository
@@ -154,7 +172,7 @@ recursiveCheckDir
   -- ^ the repository's prefix (i.e. path to its directory)
   -> FilePath
   -- ^ the repository's entrypoint (filename of a map, from the repo's root)
-  -> IO DirResult
+  -> IO (DirResult Full)
 recursiveCheckDir config prefix root = do
   maps <- recursiveCheckDir' config prefix [root] mempty
 
@@ -169,7 +187,7 @@ recursiveCheckDir config prefix root = do
   let maps' = flip mapWithKey maps $ \path res ->
         if path `elem` nowayback
         then res { mapresultGeneral =
-                   Hint Warning ("Cannot go back to " <> T.pack root <> " from this map.")
+                   Hint Warning ("Cannot go back to " <> toText root <> " from this map.")
                    : mapresultGeneral res
                  }
         else res
@@ -179,7 +197,9 @@ recursiveCheckDir config prefix root = do
                    , dirresultMissingAssets = mAssets
                    , dirresultMaps = maps'
                    , dirresultGraph =
-                     graphToDot
+                     toText
+                     . showDot
+                     . graphToDot
                      . takeSubGraph 7 root
                      $ exitGraph
                    }
@@ -187,9 +207,9 @@ recursiveCheckDir config prefix root = do
 
 -- | Given a (partially) completed DirResult, check which local
 -- maps are referenced but do not actually exist.
-missingDeps :: FilePath -> Map FilePath MapResult -> [MissingDep]
+missingDeps :: FilePath -> Map FilePath (MapResult a) -> [MissingDep]
 missingDeps entrypoint maps =
-  let simple = M.insert (T.pack entrypoint) [] used \\ M.union defined trivial
+  let simple = M.insert (toText entrypoint) [] used \\ M.union defined trivial
   in M.foldMapWithKey (\f n -> [MissingDep (Just $ not ("#" `isInfixOf` f)) f n]) simple
   where
     -- which maps are linked somewhere?
@@ -199,19 +219,19 @@ missingDeps entrypoint maps =
       (\path v -> map (, [path]) . mapMaybe (extractLocalDeps path) . mapresultDepends $ v)
       maps
       where extractLocalDeps prefix = \case
-              LocalMap name -> Just $ T.pack $ normaliseWithFrag prefix name
+              LocalMap name -> Just $ toText $ normaliseWithFrag prefix name
               _             -> Nothing
     -- which are defined using startLayer?
     defined :: Set Text
     defined = setFromList
       $ M.foldMapWithKey
-      (\k v -> map ((T.pack k <> "#") <>) . mapresultProvides $ v)
+      (\k v -> map ((toText k <> "#") <>) . mapresultProvides $ v)
       maps
     -- each map file is an entrypoint by itself
-    trivial = mapKeys T.pack $ void maps
+    trivial = mapKeys toText $ void maps
 
 -- | Checks if all assets referenced in the result actually exist as files
-missingAssets :: FilePath -> Map FilePath MapResult -> IO [MissingAsset]
+missingAssets :: FilePath -> Map FilePath (MapResult a) -> IO [MissingAsset]
 missingAssets prefix maps =
   mapM (fmap (fmap (fmap MissingAsset)) missingOfMap) (M.toList maps) <&> fold
   where missingOfMap (path, mapres) = mapMaybeM
@@ -219,7 +239,7 @@ missingAssets prefix maps =
                    let asset = normalise (takeDirectory path) relpath
                    in doesFileExist (prefix </> asset) <&>
                      \case True  -> Nothing
-                           False -> Just $ MissingDep Nothing (T.pack asset) [path]
+                           False -> Just $ MissingDep Nothing (toText asset) [path]
                  _ -> pure Nothing)
           (mapresultDepends mapres)
 
@@ -231,10 +251,10 @@ recursiveCheckDir'
   -- ^ the repo's directory
   -> [FilePath]
   -- ^ paths of maps yet to check
-  -> Map FilePath MapResult
+  -> Map FilePath (MapResult Full)
   -- ^ accumulator for map results
-  -> IO (Map FilePath MapResult)
-recursiveCheckDir' config prefix paths acc = do
+  -> IO (Map FilePath (MapResult Full))
+recursiveCheckDir' config prefix paths !acc = do
 
   -- lint all maps in paths. The double fmap skips maps which cause IO errors
   -- (in which case loadAndLintMap returns Nothing); appropriate warnings will
@@ -242,7 +262,7 @@ recursiveCheckDir' config prefix paths acc = do
   lints <-
     let lintPath p = fmap (fmap (p,)) (loadAndLintMap config (prefix </> p) depth)
           where depth = length (splitPath p) - 1
-    in mapMaybeM lintPath paths
+    in mapMaybeM lintPath paths >>= evaluateNF
 
 
   let mapdeps = setFromList (concatMap extractDeps lints)

lib/CheckMap.hs

-{-# LANGUAGE DeriveAnyClass    #-}
-{-# LANGUAGE DeriveGeneric     #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE LambdaCase        #-}
-{-# LANGUAGE NamedFieldPuns    #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE BangPatterns         #-}
+{-# LANGUAGE DataKinds            #-}
+{-# LANGUAGE DeriveGeneric        #-}
+{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE KindSignatures       #-}
+{-# LANGUAGE LambdaCase           #-}
+{-# LANGUAGE NamedFieldPuns       #-}
+{-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE RecordWildCards      #-}
+{-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE TypeFamilies         #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 -- | Module that contains the high-level checking functions
-module CheckMap (loadAndLintMap, MapResult(..)) where
+module CheckMap (loadAndLintMap, MapResult(..), ResultKind(..), Optional,shrinkMapResult) where
+
+import           Universum
 
 import           Data.Aeson       (ToJSON (toJSON))
 import qualified Data.Aeson       as A
 import           Data.Aeson.Types ((.=))
-import           Data.Functor     ((<&>))
-import           Data.Map         (Map, toList)
 import qualified Data.Map         as M
-import           Data.Text        (Text)
 import qualified Data.Text        as T
 import qualified Data.Vector      as V
-import           GHC.Generics     (Generic)
 
 
 import           Badges           (Badge)
-import           LintConfig       (LintConfig (configAssemblyTag), LintConfig')
+import           Data.Tiled       (Layer (layerLayers, layerName),
+                                   Tiledmap (tiledmapLayers, tiledmapTilesets),
+                                   loadTiledmap)
+import           LintConfig       (LintConfig (..), LintConfig')
 import           LintWriter       (LintResult, invertLintResult,
                                    resultToAdjusted, resultToBadges,
                                    resultToDeps, resultToLints, resultToOffers,
-                                   runLintWriter)
+                                   runLintWriter, resultToCWs)
 import           Properties       (checkLayer, checkMap, checkTileset)
 import           System.FilePath  (takeFileName)
-import           Tiled            (Layer (layerLayers, layerName),
-                                   LoadResult (..),
-                                   Tiledmap (tiledmapLayers, tiledmapTilesets),
-                                   loadTiledmap)
 import           Types            (Dep (MapLink),
                                    Hint (Hint, hintLevel, hintMsg), Level (..),
                                    lintsToHints)
 import           Util             (PrettyPrint (prettyprint), prettyprint)
 
 
+data ResultKind = Full | Shrunk
+
+type family Optional (a :: ResultKind) (b :: *) where
+  Optional Full b = b
+  Optional Shrunk b = ()
 
 -- | What this linter produces: lints for a single map
-data MapResult = MapResult
+data MapResult (kind :: ResultKind) = MapResult
   { mapresultLayer    :: Map Hint [Text]
   -- ^ lints that occurred in one or more layers
   , mapresultTileset  :: Map Hint [Text]
@@ -49,16 +58,20 @@ data MapResult = MapResult
   -- ^ (external and local) dependencies of this map
   , mapresultProvides :: [Text]
   -- ^ entrypoints provided by this map (needed for dependency checking)
-  , mapresultAdjusted :: Maybe Tiledmap
+  , mapresultAdjusted :: Optional kind (Maybe Tiledmap)
   -- ^ the loaded map, with adjustments by the linter
   , mapresultBadges   :: [Badge]
   -- ^ badges that can be found on this map
+  , mapresultCWs      :: [Text]
+  -- ^ collected CWs that apply to this map
   , mapresultGeneral  :: [Hint]
   -- ^ general-purpose lints that didn't fit anywhere else
   } deriving (Generic)
 
+instance NFData (Optional a (Maybe Tiledmap)) => NFData (MapResult a)
 
-instance Eq MapResult where
+
+instance Eq (MapResult a) where
   a == b =
     mapresultLayer a == mapresultLayer b &&
     mapresultTileset a == mapresultTileset b &&
@@ -66,7 +79,7 @@ instance Eq MapResult where
     mapresultGeneral a == mapresultGeneral b
 
 
-instance ToJSON MapResult where
+instance ToJSON (MapResult a) where
   toJSON res = A.object
     [ "layer" .= CollectedLints (mapresultLayer res)
     , "tileset" .= CollectedLints (mapresultTileset res)
@@ -84,40 +97,45 @@ instance ToJSON CollectedLints where
             else cs
 
 
+shrinkMapResult :: MapResult Full -> MapResult Shrunk
+shrinkMapResult !res = res { mapresultAdjusted = () }
+
 -- | this module's raison d'être
 -- Lints the map at `path`, and limits local links to at most `depth`
 -- layers upwards in the file hierarchy
-loadAndLintMap :: LintConfig' -> FilePath -> Int -> IO (Maybe MapResult)
-loadAndLintMap config path depth = loadTiledmap path <&> (\case
-    DecodeErr err -> Just (MapResult mempty mempty mempty mempty Nothing mempty
-        [ Hint Fatal . T.pack $
+loadAndLintMap :: LintConfig' -> FilePath -> Int -> IO (Maybe (MapResult Full))
+loadAndLintMap config path depth = loadTiledmap path <&> \case
+    Left err -> Just (MapResult mempty mempty mempty mempty Nothing mempty mempty
+        [ Hint Fatal . toText $
           path <> ": Fatal: " <> err
         ])
-    IOErr _ -> Nothing
-    Loaded waMap ->
-      Just (runLinter (takeFileName path == "main.json") config waMap depth))
+    Right waMap ->
+      Just (runLinter (takeFileName path == "main.json") config waMap depth)
 
 -- | lint a loaded map
-runLinter :: Bool -> LintConfig' -> Tiledmap -> Int -> MapResult
-runLinter isMain config tiledmap depth = MapResult
+runLinter :: Bool -> LintConfig' -> Tiledmap -> Int -> MapResult Full
+runLinter isMain config@LintConfig{..} tiledmap depth = MapResult
   { mapresultLayer = invertThing layer
   , mapresultTileset = invertThing tileset
   , mapresultGeneral =
-    ([Hint Error "main.json should link back to the lobby" | isMain && not (any linksLobby layerDeps)])
+    [Hint Warning "main.json should link back to the lobby"
+       | isMain && not (any linksLobby layerDeps)]
     <> lintsToHints (resultToLints generalResult)
   , mapresultDepends = resultToDeps generalResult
     <> layerDeps
     <> concatMap resultToDeps tileset
   , mapresultProvides = concatMap resultToOffers layer
   , mapresultAdjusted = Just adjustedMap
+  , mapresultCWs = resultToCWs generalResult
   , mapresultBadges = concatMap resultToBadges layer
     <> resultToBadges generalResult
   }
   where
     linksLobby = \case
-      MapLink link -> "/@/rc3_21/lobby" `T.isPrefixOf` link
-        || configAssemblyTag config == "lobby"
-      _ -> False
+      MapLink link ->
+        ("/@/"<>configEventSlug<>"/lobby") `T.isPrefixOf` link
+        || configAssemblyTag == "lobby"
+      _  -> False
     layerDeps = concatMap resultToDeps layer
     layer = checkLayerRec config depth (V.toList $ tiledmapLayers tiledmap)
     tileset = checkThing tiledmapTilesets checkTileset
@@ -183,7 +201,7 @@ checkLayerRec config depth layers =
 
 
 -- human-readable lint output, e.g. for consoles
-instance PrettyPrint (Level, MapResult) where
+instance PrettyPrint (Level, MapResult a) where
   prettyprint (_, mapResult) = if complete == ""
     then "  all good!\n" else complete
     where
@@ -194,11 +212,10 @@ instance PrettyPrint (Level, MapResult) where
       -- | pretty-prints a collection of Hints, printing each
       --   Hint only once, then a list of its occurences line-wrapped
       --   to fit onto a decent-sized terminal
-      prettyLints :: (MapResult -> Map Hint [Text]) -> [Text]
+      prettyLints :: (MapResult a -> Map Hint [Text]) -> [Text]
       prettyLints getter = fmap
         (\(h, cs) -> prettyprint h
           <> "\n    (in "
-          -- foldl :: ((length of current line, acc) -> next ctxt -> list) -> ...
           <> snd (foldl (\(l,a) c -> case l of
                             0 -> (T.length c, c)
                             _ | l < 70 -> (l+2+T.length c, a <> ", " <> c)
@@ -206,7 +223,7 @@ instance PrettyPrint (Level, MapResult) where
                         )
              (0, "") cs)
           <> ")\n")
-        (toList . getter $ mapResult)
+        (M.toList . getter $ mapResult)
 
       prettyGeneral :: [Text]
       prettyGeneral = map

lib/Dirgraph.hs

-{-# LANGUAGE LambdaCase    #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase       #-}
+{-# LANGUAGE TupleSections    #-}
 
 -- | Simple directed graphs, for dependency checking
 module Dirgraph where
 
+import           Universum
 
-import           CheckMap              (MapResult (mapresultDepends))
-import           Control.Monad         (forM_, unless)
-import           Data.Functor          ((<&>))
-import           Data.Map.Strict       (Map, mapMaybeWithKey, mapWithKey,
-                                        traverseMaybeWithKey, traverseWithKey)
-import qualified Data.Map.Strict       as M
-import           Data.Maybe            (fromMaybe)
-import           Data.Set              (Set, (\\))
-import qualified Data.Set              as S
-import           Paths                 (normalise)
-import qualified System.FilePath       as FP
-import           System.FilePath.Posix (takeDirectory, (</>))
-import           Text.Dot              (Dot, (.->.))
-import qualified Text.Dot              as D
-import           Types                 (Dep (LocalMap))
-import           Witherable            (mapMaybe)
+import           CheckMap        (MapResult (mapresultDepends))
+import           Data.Map.Strict (mapMaybeWithKey, mapWithKey, traverseWithKey)
+import qualified Data.Map.Strict as M
+import           Data.Set        ((\\))
+import qualified Data.Set        as S
+import           Paths           (normalise)
+import           Text.Dot        (Dot, (.->.))
+import qualified Text.Dot        as D
+import           Types           (Dep (LocalMap))
 
 -- | a simple directed graph
 type Graph a = Map a (Set a)
@@ -29,18 +24,16 @@ nodes :: Graph a -> Set a
 nodes = M.keysSet
 
 -- | simple directed graph of exits
-resultToGraph :: Map FilePath MapResult -> Graph FilePath
-resultToGraph = mapWithKey (\p r -> S.fromList
-                             . mapMaybe (onlyLocalMaps (takeDirectory p))
-                             . mapresultDepends $ r)
-  where onlyLocalMaps prefix = \case
-          LocalMap path -> Just (FP.normalise (prefix </> normalise "" path))
+resultToGraph :: Map FilePath (MapResult a) -> Graph FilePath
+resultToGraph = fmap (S.fromList . mapMaybe onlyLocalMaps . mapresultDepends)
+  where onlyLocalMaps = \case
+          LocalMap path -> Just (normalise "" path)
           _             -> Nothing
 
 -- | invert edges of a directed graph
 invertGraph :: (Eq a, Ord a) => Graph a -> Graph a
 invertGraph graph = mapWithKey collectFroms graph
-  where collectFroms to _ = S.fromList . M.elems . mapMaybeWithKey (select to) $ graph
+  where collectFroms to _ = S.fromList . elems . mapMaybeWithKey (select to) $ graph
         select to from elems = if to `elem` elems then Just from else Nothing
 
 -- | all nodes reachable from some entrypoint
@@ -75,7 +68,7 @@ takeSubGraph i start graph
 graphToDot :: Graph FilePath -> Dot ()
 graphToDot graph = do
   main <- D.node [("label","main.json")]
-  nodes' <- traverseMaybeWithKey
+  nodes' <- M.traverseMaybeWithKey
     (\name edges -> if name /= "main.json"
       then D.node [("label",name)] <&> (, edges) <&> Just
       else pure Nothing

lib/LayerData.hs

@@ -2,13 +2,13 @@
 
 module LayerData where
 
+import           Universum         hiding (maximum, uncons)
 
 import           Control.Monad.Zip (mzipWith)
-import           Data.Set          (Set, insert)
-import           Data.Text         (Text)
-import qualified Data.Text         as T
-import           Data.Vector       (Vector, uncons)
-import           Tiled             (GlobalId (unGlobalId), Layer (..))
+import           Data.Set          (insert)
+import           Data.Tiled        (GlobalId (unGlobalId), Layer (..))
+import           Data.Vector       (maximum, uncons)
+import qualified Text.Show         as TS
 import           Util              (PrettyPrint (..))
 
 -- | A collision between two layers of the given names.
@@ -22,8 +22,8 @@ instance Eq Collision where
 instance PrettyPrint Collision where
   prettyprint (Collision (a,b)) = a <> " and " <> b
 
-instance Show Collision where
-  show c = T.unpack $ prettyprint c
+instance TS.Show Collision where
+  show c = toString $ prettyprint c
 
 -- | Finds pairwise tile collisions between the given layers.
 layerOverlaps :: Vector Layer -> Set Collision

lib/LintConfig.hs

+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DeriveAnyClass        #-}
 {-# LANGUAGE DeriveGeneric         #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE LambdaCase            #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE RecordWildCards       #-}
 {-# LANGUAGE StandaloneDeriving    #-}
 {-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE TypeOperators         #-}
 {-# LANGUAGE UndecidableInstances  #-}
 
 -- | Module that deals with handling config options
-module LintConfig where
-
-import           Control.Monad.Identity (Identity)
-import           Data.Aeson             (FromJSON (parseJSON), Options (..),
-                                         defaultOptions, eitherDecode)
-import           Data.Aeson.Types       (genericParseJSON)
-import qualified Data.ByteString.Char8  as C8
-import qualified Data.ByteString.Lazy   as LB
-import qualified Data.Map.Strict        as M
-import           Data.Text              (Text)
-import           GHC.Generics           (Generic (Rep, from, to), K1 (..),
-                                         M1 (..), (:*:) (..))
-import           Types                  (Level)
-import           Uris                   (SchemaSet,
-                                         Substitution (DomainSubstitution))
-import           WithCli                (Proxy (..))
-import           WithCli.Pure           (Argument (argumentType, parseArgument))
-
-type family HKD f a where
-  HKD Identity a = a
-  HKD f a = f a
-
-data LintConfig f = LintConfig
-  { configScriptInject   :: HKD f (Maybe Text)
+module LintConfig (LintConfig(..), LintConfig', ConfigKind (..), patchConfig,stuffConfig,feedConfig) where
+
+import           Universum
+
+import           Data.Aeson            (FromJSON (parseJSON), Options (..),
+                                        defaultOptions, eitherDecode)
+import           Data.Aeson.Types      (genericParseJSON)
+import qualified Data.ByteString.Char8 as C8
+import qualified Data.ByteString.Lazy  as LB
+import qualified Data.Map.Strict       as M
+import           GHC.Generics          (Generic (Rep, from, to), K1 (..),
+                                        M1 (..), (:*:) (..))
+import           Types                 (Level)
+import           Uris                  (SchemaSet,
+                                        Substitution (DomainSubstitution))
+import           WithCli.Pure          (Argument (argumentType, parseArgument))
+
+
+
+data ConfigKind = Complete | Basic | Skeleton | Patch
+
+-- | a field that must be given in configs for both server & standalone linter
+type family ConfigField (f::ConfigKind) a where
+  ConfigField Patch a = Maybe a
+  ConfigField _ a = a
+
+-- | a field that must be given for the standalone linter, but not the server
+-- (usually because the server will infer them from its own config)
+type family StandaloneField (f :: ConfigKind) a where
+  StandaloneField Complete a = a
+  StandaloneField Skeleton a = a
+  StandaloneField _ a = Maybe a
+
+-- | a field specific to a single world / assembly
+type family WorldField (f :: ConfigKind) a where
+  WorldField Complete a = a
+  WorldField _ a = Maybe a
+
+data LintConfig (f :: ConfigKind) = LintConfig
+  { configScriptInject   :: ConfigField f (Maybe Text)
   -- ^ Link to Script that should be injected
-  , configAssemblyTag    :: HKD f Text
+  , configAssemblyTag    :: WorldField f Text
   -- ^ Assembly name (used for jitsiRoomAdminTag)
-  , configAssemblies     :: HKD f [Text]
+  , configAssemblies     :: StandaloneField f [Text]
   -- ^ list of all assembly slugs (used to lint e.g. world:// links)
-  , configMaxLintLevel   :: HKD f Level
+  , configEventSlug      :: StandaloneField f Text
+  -- ^ slug of this event (used e.g. to resolve world:// links)
+  , configMaxLintLevel   :: ConfigField f Level
   -- ^ Maximum warn level allowed before the lint fails
-  , configDontCopyAssets :: HKD f Bool
+  , configDontCopyAssets :: ConfigField f Bool
   -- ^ Don't copy map assets (mostly useful for development)
-  , configAllowScripts   :: HKD f Bool
+  , configAllowScripts   :: ConfigField f Bool
   -- ^ Allow defining custom scripts in maps
-  , configUriSchemas     :: HKD f SchemaSet
+  , configUriSchemas     :: ConfigField f SchemaSet
   } deriving (Generic)
 
-type LintConfig' = LintConfig Identity
+type LintConfig' = LintConfig Complete
 
--- TODO: should probably find a way to write these constraints nicer ...
-deriving instance
-  ( Show (HKD a (Maybe Text))
-  , Show (HKD a Text)
-  , Show (HKD a Level)
-  , Show (HKD a [Text])
-  , Show (HKD a Bool)
-  , Show (HKD a SchemaSet)
-  )
-  => Show (LintConfig a)
+deriving instance Show (LintConfig Complete)
+deriving instance Show (LintConfig Skeleton)
+deriving instance Show (LintConfig Patch)
+instance NFData (LintConfig Basic)
 
 aesonOptions :: Options
 aesonOptions = defaultOptions
@@ -68,23 +83,13 @@ aesonOptions = defaultOptions
   , fieldLabelModifier = drop 6
   }
 
-instance
-    ( FromJSON (HKD a (Maybe Text))
-    , FromJSON (HKD a [Text])
-    , FromJSON (HKD a Text)
-    , FromJSON (HKD a Level)
-    , FromJSON (HKD a Bool)
-    , FromJSON (HKD a SchemaSet)
-    )
-    => FromJSON (LintConfig a)
-  where
-    parseJSON = genericParseJSON aesonOptions
+instance FromJSON (LintConfig Complete) where
+  parseJSON = genericParseJSON aesonOptions
 
--- need to define this one extra, since Aeson will not make
--- Maybe fields optional if the type isn't given explicitly.
---
--- Whoever said instances had confusing semantics?
-instance {-# Overlapping #-} FromJSON (LintConfig Maybe) where
+instance FromJSON (LintConfig Patch) where
+  parseJSON = genericParseJSON aesonOptions
+
+instance FromJSON (LintConfig Basic) where
   parseJSON = genericParseJSON aesonOptions
 
 
@@ -118,30 +123,66 @@ instance GPatch i o
 -- abstract, I just wanted to play around with higher kinded types for
 -- a bit.
 patch ::
-  ( Generic (f Maybe)
-  , Generic (f Identity)
-  , GPatch (Rep (f Identity))
-    (Rep (f Maybe))
+  ( Generic (f Patch)
+  , Generic (f Complete)
+  , GPatch (Rep (f Complete))
+    (Rep (f Patch))
   )
-  => f Identity
-  -> f Maybe
-  -> f Identity
+  => f Complete
+  -> f Patch
+  -> f Complete
 patch x y = to (gappend (from x) (from y))
 
-patchConfig :: LintConfig Identity -> Maybe (LintConfig Maybe) -> LintConfig Identity
-patchConfig config p = config'
-  { configUriSchemas = ("world", assemblysubsts) : configUriSchemas config'}
-  where config' = case p of
-          Just p  -> patch config p
-          Nothing -> config
-        assemblysubsts =
-          DomainSubstitution (M.fromList generated) scope
-          where generated = (\slug -> (slug, "/@/rc3_21/"<>slug)) <$> configAssemblies config'
-        scope = (\(DomainSubstitution _ s) -> s)
-         . snd . head
-         . filter ((==) "world" . fst)
-         $ configUriSchemas config'
-
+patchConfig
+  :: LintConfig Complete
+  -> Maybe (LintConfig Patch)
+  -> LintConfig Complete
+patchConfig config p = expandWorlds config'
+  where
+    config' = case p of
+      Just p  -> patch config p
+      Nothing -> config
+
+
+-- | feed a basic server config
+feedConfig
+  :: LintConfig Basic
+  -> [Text]
+  -> Text
+  -> LintConfig Skeleton
+feedConfig LintConfig{..} worlds eventslug = expandWorlds $
+  LintConfig
+  { configAssemblies = worlds
+  , configEventSlug = eventslug
+  , .. }
+
+-- | stuff a
+stuffConfig :: LintConfig Skeleton -> Text -> LintConfig Complete
+stuffConfig LintConfig{..} assemblyslug =
+  LintConfig
+  { configAssemblyTag = assemblyslug
+  , ..}
+
+class HasWorldList (a :: ConfigKind)
+instance HasWorldList 'Complete
+instance HasWorldList 'Skeleton
+
+-- kinda sad that ghc can't solve these contraints automatically,
+-- though i guess it also makes sense …
+expandWorlds
+  :: ( ConfigField a SchemaSet ~ SchemaSet
+     , StandaloneField a [Text] ~ [Text]
+     , StandaloneField a Text ~ Text
+     , HasWorldList a)
+  => LintConfig a -> LintConfig a
+expandWorlds config = config { configUriSchemas = configUriSchemas' }
+  where
+    configUriSchemas' =
+      M.insert "world:" [assemblysubsts] (configUriSchemas config)
+    assemblysubsts =
+      DomainSubstitution (M.fromList generated) ["map"]
+      where generated = configAssemblies config
+              <&> \slug -> (slug, "/@/"<>configEventSlug config<>"/"<>slug)
 
 instance (FromJSON (LintConfig a)) => Argument (LintConfig a) where
   parseArgument str =

lib/LintWriter.hs

@@ -40,23 +40,17 @@ module LintWriter
   , lintConfig
   -- * adjust the linter's context
   , adjust
-  ) where
+  ,offersCWs,resultToCWs) where
 
-import           Data.Text                  (Text)
+import           Universum
 
-import           Badges                     (Badge)
-import           Control.Monad.State        (MonadState (put), StateT, modify)
-import           Control.Monad.Trans.Reader (Reader, asks, runReader)
-import           Control.Monad.Trans.State  (get, runStateT)
-import           Control.Monad.Writer.Lazy  (lift)
-import           Data.Bifunctor             (Bifunctor (second))
-import           Data.Map                   (Map, fromListWith)
-import           Data.Maybe                 (mapMaybe)
-import qualified Data.Set                   as S
-import           LintConfig                 (LintConfig')
-import           TiledAbstract              (HasName (getName))
-import           Types                      (Dep, Hint, Level (..), Lint (..),
-                                             hint, lintsToHints)
+
+import           Badges              (Badge)
+import           Data.Map            (fromListWith)
+import           Data.Tiled.Abstract (HasName (getName))
+import           LintConfig          (LintConfig')
+import           Types               (Dep, Hint, Level (..), Lint (..), hint,
+                                      lintsToHints)
 
 
 -- | A monad modelling the main linter features
@@ -109,7 +103,7 @@ zoom embed extract operation = do
 -- | "invert" a linter's result, grouping lints by their messages
 invertLintResult :: HasName ctxt => LintResult ctxt -> Map Hint [Text]
 invertLintResult (LinterState (lints, ctxt)) =
-  fmap (S.toList . S.fromList . fmap getName) . fromListWith (<>) $ (, [ctxt]) <$> lintsToHints lints
+  fmap (sortNub . map getName) . fromListWith (<>) $ (, [ctxt]) <$> lintsToHints lints
 
 resultToDeps :: LintResult a -> [Dep]
 resultToDeps (LinterState (lints,_)) = mapMaybe lintToDep lints
@@ -128,6 +122,11 @@ resultToBadges (LinterState a) = mapMaybe lintToBadge $ fst a
   where lintToBadge (Badge badge) = Just badge
         lintToBadge _             = Nothing
 
+resultToCWs :: LintResult a -> [Text]
+resultToCWs (LinterState a) = fold $ mapMaybe lintToCW $ fst a
+  where lintToCW = \case (CW cw) -> Just cw; _ -> Nothing
+
+
 -- | convert a lint result into a flat list of lints
 resultToLints :: LintResult a -> [Lint]
 resultToLints (LinterState res) = fst res
@@ -158,6 +157,8 @@ offersEntrypoint text = tell' $ Offers text
 offersBadge :: Badge -> LintWriter a
 offersBadge badge = tell' $ Badge badge
 
+offersCWs :: [Text] -> LintWriter a
+offersCWs = tell' . CW
 
 
 -- | get the context as it was initially, without any modifications

lib/Paths.hs

+{-# LANGUAGE DeriveAnyClass    #-}
+{-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE MultiWayIf        #-}
 {-# LANGUAGE OverloadedStrings #-}
 
@@ -5,18 +7,21 @@
 -- I just hope you are running this on some kind of Unix
 module Paths where
 
-import           Data.Text             (Text, isPrefixOf)
+import           Universum
+import qualified Universum.Unsafe      as Unsafe
+
 import qualified Data.Text             as T
 import           System.FilePath       (splitPath)
 import           System.FilePath.Posix ((</>))
 import           Text.Regex.TDFA
 import           Util                  (PrettyPrint (prettyprint))
 
+
 -- | a normalised path: a number of "upwards" steps, and
 -- a path without any . or .. in it. Also possibly a
 -- fragment, mostly for map links.
 data RelPath = Path Int Text (Maybe Text)
-  deriving (Show, Eq, Ord)
+  deriving (Show, Eq, Ord, NFData, Generic)
 
 
 
@@ -32,9 +37,9 @@ parsePath :: Text -> PathResult
 parsePath text =
   if | T.isInfixOf "{{" text || T.isInfixOf "}}" text -> PathVarsDisallowed
      | rest =~ ("^([^/]*[^\\./]/)*[^/]*[^\\./]$" :: Text) -> OkRelPath (Path up path fragment)
-     | "/_/" `isPrefixOf` text ->  UnderscoreMapLink
-     | "/@/" `isPrefixOf` text ->  AtMapLink
-     | "/" `isPrefixOf` text ->  AbsolutePath
+     | "/_/" `T.isPrefixOf` text ->  UnderscoreMapLink
+     | "/@/" `T.isPrefixOf` text ->  AtMapLink
+     | "/" `T.isPrefixOf` text ->  AbsolutePath
      | otherwise ->  NotAPath
   where
     (_, prefix, rest, _) =
@@ -43,10 +48,10 @@ parsePath text =
     up = length . filter (".." ==) . T.splitOn  "/" $ prefix
     parts = T.splitOn "#" rest
     -- `head` is unsafe, but splitOn will always produce lists with at least one element
-    path = head parts
-    fragment = if length parts >= 2
-      then Just $ T.concat $ tail parts
-      else Nothing
+    path = Unsafe.head parts
+    fragment = case nonEmpty parts of
+      Nothing -> Nothing
+      Just p  -> Just $ T.concat $ tail p
 
 instance PrettyPrint RelPath where
   prettyprint (Path up rest frag) = ups <> rest <> fragment
@@ -59,14 +64,14 @@ instance PrettyPrint RelPath where
 -- at the end of the prefix, i.e. it will never return paths
 -- that lie (naïvely) outside of the prefix.
 normalise :: FilePath -> RelPath ->  FilePath
-normalise prefix (Path 0 path _) = prefix </> T.unpack path
+normalise prefix (Path 0 path _) = prefix </> toString path
 normalise prefix (Path i path _) =
-  concat (take (length dirs - i) dirs) </> T.unpack path
+  concat (take (length dirs - i) dirs) </> toString path
   where dirs = splitPath prefix
 
 normaliseWithFrag :: FilePath -> RelPath -> FilePath
 normaliseWithFrag prefix (Path i path frag) =
-  normalise prefix (Path (i+1) path frag) <> T.unpack (maybe mempty ("#" <>) frag)
+  normalise prefix (Path (i+1) path frag) <> toString (maybe mempty ("#" <>) frag)
 
 -- | does this path contain an old-style pattern for inter-repository
 -- links as was used at rc3 in 2020?
@@ -77,7 +82,5 @@ isOldStyle (Path _ text frag) = path =~ ("{<.+>*}" :: Text)
           _      -> text
 
 getExtension :: RelPath -> Text
-getExtension (Path _ text _) = case length splitted of
-  0 -> ""
-  _ -> last splitted
+getExtension (Path _ text _) = maybe "" last (nonEmpty splitted)
   where splitted = T.splitOn "." text