.gitlab-ci.yml

-image: haskell:8.10.7
+image: haskell:9.0.2
 
 stages:
   - build
-  - trigger
+  # - trigger
 
 build-job:
   stage: build
@@ -23,10 +23,10 @@ build-job:
     - .stack-root/
 
 
-trigger-mapservice-pipeline:
-  only:
-    refs:
-      - main
-  stage: trigger
-  script:
-    - curl -X POST -F token=$MAPSERVICE_TOKEN -F ref=main https://git.cccv.de/api/v4/projects/252/trigger/pipeline
+# trigger-mapservice-pipeline:
+#   only:
+#     refs:
+#       - main
+#   stage: trigger
+#   script:
+#     - curl -X POST -F token=$MAPSERVICE_TOKEN -F ref=main https://git.cccv.de/api/v4/projects/252/trigger/pipeline

Readme.md

@@ -7,43 +7,44 @@ 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).
+enforce an event's map policies (among other things, this was used to resolve 
+special inter-assembly `world://` links at rc3).
 
 `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.
+to a path that can then be served as static map files for a workadventure
+deployment. It can be used as a (very simple) replacement for rc3's hub and
+mapservice at smaller events — to get started, manually list all map
+repositories in `config.toml`, then visit `localhost:8080/admin/overview`.
 
-`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
 
 ### From the CI pipeline
 
 Gitlab [automatically builds a version](https://git.cccv.de/hub/walint/-/jobs)
-of `walint` each time something is pushed to this repository. The resulting
-binary should work fine on most linux systems, especially if they're vaguely
-debian-like.
+of `walint` each time something is pushed to the version of this repository
+kept at the CCCV infra. The resulting binary should work fine on most linux 
+systems, especially if they're vaguely debian-like.
 
 In case you get an incomprehensible or confusing error when executing it, try 
-running `ldd walint` and see if anything is marked as not found, then install it.
+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 [the haskell stack](https://docs.haskellstack.org/en/stable/README/).
+This uses a lockfile to pin versions of dependencies (as well as `ghc`, the 
+haskell compiler). You will need 
+[the haskell stack](https://docs.haskellstack.org/en/stable/README/).
 
-Then just run
+Run
 
 ```
 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 NixOS, `stack` may
+If you lack `ghc` and don't know how to install it, you can add  `--install-ghc`,
+and `stack` will 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
@@ -58,9 +59,6 @@ Alternatively, run `walint` via stack:
 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, increasing startup time.
-
 ### Build using cabal
 
 You can, but probably should not. Beware of older Aeson versions!
@@ -79,8 +77,8 @@ walint --config-file config.json --repository path \
    defaults to `main.json`
  - `--lintLevel`: limit output only to messages that have at most the given
    level. Valid levels are `Info`, `Suggestion`, `Warning`, `Forbidden`, `Error`,
-   `Fatal`. Defaults to `Suggestion` if not given.
- - `--json`: print output as json instead of the normal more human-friendly format
+   `Fatal`. Defaults to `Suggestion`.
+ - `--json`: print output as json instead of the default human-friendly format
  - `--pretty`: if used with `--json`, insert line breaks and indentation to make
    the output more readable. Otherwise no effect.
  - `--out path`: write the linted & adjusted repository to the given path. Any
@@ -103,40 +101,45 @@ have default values. In `config.json`, all possible keys are given.
 Most options should be reasonably self-explanatory. Note that `MaxLintLevel`
 differs from the option `--lintLevel`: the latter merely determines what is
 *printed* (in case json output is not enabled), the former determines the 
-maximum lint level allowed before the linter rejects the map and does not
-copy it to the path given to `--out`.
+maximum lint level allowed before the linter rejects the map and will refuse to
+copy it to the path given as `--out`.
 
 ### Uri Schemas
 
-`walint` supports (limited) rewriting of URIs contained in the map json via
-the `UriSchemas` option, which takes a map from uri schemas to a rule describing
-what to do with such links, depending on the scope in which they appear.
+`walint` supports (basic) rewriting of URIs contained in the map json via the
+`UriSchemas` option, which maps schemas to rules describing what to do with such
+links, depending on the scope in which they appear.
 
 `walint` takes a very reductive view or URIs: `schema://domain/tail`
 
 #### Rewrite Rules
 
-For now there are three types of such rules:
+For now there are four types of such rules:
  - `schema: {"scope":[scopes]}`: if in a scope listed in `scopes`, allow any
    links of the given `schema`
+ - `schema: {"scope":[scopes], "allowed":[allowed]}`: if in a scope listed in
+   `scopes`, only allow URIs whose domain occurs in `allowed`.
  - `schema: {"scope":[scopes], "allowed":[allowed], "blocked":[blocked], "prefix":prefix}`: 
-   if in a scope listed in `scopes`, prefix any URIs of the given `schema` with
-   the given `prefix`, unless the URI's domain occurs in `allowed` (in which case
-   leave it untouched), or it occurs in `blocked`, in which
-   case it will be rejected as a lint error.
- - `schema: {"scope":[scopes], "subst":{domain: prefix, ...}}`: if in a scope
-   listed in `scopes` and given a URI with the domain `domain`, concatenate 
-   `prefix` with the tail of this URI.
+   if in a scope listed in `scopes`, allow URIs whose domain occurs in `allowed`,
+   disallow all whose domain occurs in `blocked`, and for all others, prefix
+   with the string given as `prefix`
+ - `schema: {"scope":[scopes], "substs":{domain: prefix, ...}}`: if in a 
+   scope listed in `scopes` and given a URI with the domain `domain`,
+   concatenate `prefix` with the tail of this URI.
 
-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!)
+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 three possible scopes: `map` applies to tiled map links 
-(i.e. `exitUrl`), `website` to `openWebsite`, `audio` to `playAudio`.
+There are currently four scopes:
+ - `map` applies to tiled map links (i.e. `exitUrl`)
+ - `website` to `openWebsite`
+ - `audio` to `playAudio`
+ - `script` to scripts
 
 
 ## Output
-By default `walint` prints lints in a hopefully human-readable manner. Its exit
+By default `walint` prints lints in a (hopefully) human-readable format. Its exit
 code will be 1 if the maximum lint level set in its config was exceeded, and 0
 otherwise. Only in the latter case will it write out an adjusted map respository
 to the path passed to `--out`. If the path given to `--out` already exists, 

config.json

@@ -12,7 +12,7 @@
       },
       {
         "scope" : [ "script" ],
-        "allowed" : [ "scripts.world.di.c3voc.de" ]
+        "allowed" : [ "example.org" ]
       }]
   }
 }

config.toml

@@ -17,29 +17,29 @@ token = "hello, world!"
 slug = "divoc"
 
 # baseurl of maps as seen by the frontend
-url = "https://world.di.c3voc.de/maps/"
+url = "https://example.org/maps/"
 # webdir into which maps should be written
-webdir = "/tmp/var/www/divoc"
+webdir = "/tmp/var/www/example"
+
+webdir_human = "/tmp/var/www-human/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"
+contact_mail = "world@example.org"
+howto_link = "https://example.org"
 
 # 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"
+
+
+# add more repos here …

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

+{ nixpkgs ? import <nixpkgs> {}, compiler ? "default", doBenchmark ? false }:
+
 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"; });
+  inherit (nixpkgs) pkgs;
+
+  f = { mkDerivation, aeson, aeson-pretty, async, base, base-compat
+      , base64-bytestring, bytestring, containers, cryptohash-sha1
+      , deepseq, directory, dotgen, either, extra, filepath, fmt
+      , getopt-generics, hpack, http-client, http-types, lib, lucid
+      , microlens-platform, monad-logger, network-uri, process
+      , regex-tdfa, servant, servant-client, servant-lucid
+      , servant-server, servant-websockets, stm, template-haskell, text
+      , text-metrics, time, tomland, transformers, universum, uri-encode
+      , uuid, vector, wai, wai-extra, warp, websockets
+      }:
+      mkDerivation {
+        pname = "walint";
+        version = "0.1";
+        src = ./.;
+        isLibrary = true;
+        isExecutable = true;
+        libraryHaskellDepends = [
+          aeson base bytestring containers deepseq dotgen either extra
+          filepath getopt-generics network-uri regex-tdfa text text-metrics
+          transformers universum uri-encode vector
+        ];
+        libraryToolDepends = [ hpack ];
+        executableHaskellDepends = [
+          aeson aeson-pretty async base base-compat base64-bytestring
+          bytestring containers cryptohash-sha1 directory extra filepath fmt
+          getopt-generics http-client http-types lucid microlens-platform
+          monad-logger process servant servant-client servant-lucid
+          servant-server servant-websockets stm template-haskell text time
+          tomland universum uuid wai wai-extra warp websockets
+        ];
+        doHaddock = false;
+        prePatch = "hpack";
+        homepage = "https://stuebinm.eu/git/walint";
+        license = "unknown";
+        hydraPlatforms = lib.platforms.none;
+      };
+
+  haskellPackages = if compiler == "default"
+                       then pkgs.haskellPackages
+                       else pkgs.haskell.packages.${compiler};
+
+  variant = if doBenchmark then pkgs.haskell.lib.doBenchmark else pkgs.lib.id;
+
+  drv = variant (haskellPackages.callPackage f {});
 
-  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
-    '';
-  };
-}
+  drv

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;
-}

flake.lock

+{
+  "nodes": {
+    "nixpkgs": {
+      "locked": {
+        "lastModified": 1665466769,
+        "narHash": "sha256-L+qcHpb4Ac3PipMXJY/Ktbu1+KXy23WCZ8pXWmsf7zY=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "0b20bf89e0035b6d62ad58f9db8fdbc99c2b01e8",
+        "type": "github"
+      },
+      "original": {
+        "owner": "NixOS",
+        "ref": "release-22.05",
+        "repo": "nixpkgs",
+        "type": "github"
+      }
+    },
+    "root": {
+      "inputs": {
+        "nixpkgs": "nixpkgs"
+      }
+    }
+  },
+  "root": "root",
+  "version": 7
+}

flake.nix

+{
+  description = "walint: workadventure map linting";
+
+  inputs.nixpkgs.url = "github:NixOS/nixpkgs/release-22.05";
+
+  outputs = { self, nixpkgs }:
+  {
+    defaultPackage.x86_64-linux = import ./default.nix { 
+      nixpkgs = import nixpkgs { system = "x86_64-linux"; }; 
+    };
+  };
+}

lib/CheckDir.hs

@@ -35,12 +35,11 @@ import qualified Data.Text              as T
 import           Data.Tiled             (Tiledmap)
 import           Dirgraph               (graphToDot, invertGraph, resultToGraph,
                                          takeSubGraph, unreachableFrom)
-import           GHC.Generics           (Generic)
 import           LintConfig             (LintConfig', configMaxLintLevel)
 import           Paths                  (normalise, normaliseWithFrag)
 import           System.Directory.Extra (doesFileExist)
-import           System.FilePath        (splitPath, (</>))
 import qualified System.FilePath        as FP
+import           System.FilePath        (splitPath, (</>))
 import           System.FilePath.Posix  (takeDirectory)
 import           Text.Dot               (showDot)
 import           Types                  (Dep (Local, LocalMap), Hint (Hint),

lib/CheckMap.hs

@@ -32,8 +32,8 @@ import           Data.Tiled       (Layer (layerLayers, layerName),
 import           LintConfig       (LintConfig (..), LintConfig')
 import           LintWriter       (LintResult, invertLintResult,
                                    resultToAdjusted, resultToBadges,
-                                   resultToDeps, resultToLints, resultToOffers,
-                                   runLintWriter, resultToCWs)
+                                   resultToCWs, resultToDeps, resultToJitsis,
+                                   resultToLints, resultToOffers, runLintWriter)
 import           Properties       (checkLayer, checkMap, checkTileset)
 import           System.FilePath  (takeFileName)
 import           Types            (Dep (MapLink),
@@ -44,7 +44,7 @@ import           Util             (PrettyPrint (prettyprint), prettyprint)
 
 data ResultKind = Full | Shrunk
 
-type family Optional (a :: ResultKind) (b :: *) where
+type family Optional (a :: ResultKind) (b :: Type) where
   Optional Full b = b
   Optional Shrunk b = ()
 
@@ -64,6 +64,8 @@ data MapResult (kind :: ResultKind) = MapResult
   -- ^ badges that can be found on this map
   , mapresultCWs      :: [Text]
   -- ^ collected CWs that apply to this map
+  , mapresultJitsis   :: [Text]
+  -- ^ all jitsi room slugs mentioned in this map
   , mapresultGeneral  :: [Hint]
   -- ^ general-purpose lints that didn't fit anywhere else
   } deriving (Generic)
@@ -105,9 +107,8 @@ shrinkMapResult !res = res { mapresultAdjusted = () }
 -- layers upwards in the file hierarchy
 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
+    Left err -> Just (MapResult mempty mempty mempty mempty Nothing mempty mempty mempty
+        [ Hint Fatal . toText $ "Fatal: " <> err
         ])
     Right waMap ->
       Just (runLinter (takeFileName path == "main.json") config waMap depth)
@@ -127,6 +128,8 @@ runLinter isMain config@LintConfig{..} tiledmap depth = MapResult
   , mapresultProvides = concatMap resultToOffers layer
   , mapresultAdjusted = Just adjustedMap
   , mapresultCWs = resultToCWs generalResult
+  , mapresultJitsis = concatMap resultToJitsis tileset
+    <> concatMap resultToJitsis layer
   , mapresultBadges = concatMap resultToBadges layer
     <> resultToBadges generalResult
   }

lib/Dirgraph.hs

@@ -8,13 +8,13 @@ module Dirgraph where
 import           Universum
 
 import           CheckMap        (MapResult (mapresultDepends))
-import           Data.Map.Strict (mapMaybeWithKey, mapWithKey, traverseWithKey)
+import           Data.Map.Strict (mapMaybeWithKey, mapWithKey)
 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           Text.Dot        (Dot, (.->.))
 import           Types           (Dep (LocalMap))
 
 -- | a simple directed graph

lib/LintWriter.hs

@@ -40,7 +40,7 @@ module LintWriter
   , lintConfig
   -- * adjust the linter's context
   , adjust
-  ,offersCWs,resultToCWs) where
+  ,offersCWs,resultToCWs,offersJitsi,resultToJitsis) where
 
 import           Universum
 
@@ -126,6 +126,9 @@ resultToCWs :: LintResult a -> [Text]
 resultToCWs (LinterState a) = fold $ mapMaybe lintToCW $ fst a
   where lintToCW = \case (CW cw) -> Just cw; _ -> Nothing
 
+resultToJitsis :: LintResult a -> [Text]
+resultToJitsis (LinterState a) = mapMaybe lintToJitsi $ fst a
+  where lintToJitsi = \case (Jitsi room) -> Just room; _ -> Nothing
 
 -- | convert a lint result into a flat list of lints
 resultToLints :: LintResult a -> [Lint]
@@ -160,6 +163,9 @@ offersBadge badge = tell' $ Badge badge
 offersCWs :: [Text] -> LintWriter a
 offersCWs = tell' . CW
 
+offersJitsi :: Text -> LintWriter a
+offersJitsi = tell' . Jitsi
+
 
 -- | get the context as it was initially, without any modifications
 askContext :: LintWriter' a a

lib/Properties.hs

@@ -37,8 +37,9 @@ import           LayerData           (Collision, layerOverlaps)
 import           LintConfig          (LintConfig (..))
 import           LintWriter          (LintWriter, adjust, askContext,
                                       askFileDepth, complain, dependsOn, forbid,
-                                      lintConfig, offersBadge, offersEntrypoint,
-                                      suggest, warn, zoom, offersCWs)
+                                      lintConfig, offersBadge, offersCWs,
+                                      offersEntrypoint, offersJitsi, suggest,
+                                      warn, zoom)
 import           Paths               (PathResult (..), RelPath (..),
                                       getExtension, isOldStyle, parsePath)
 import           Types               (Dep (Link, Local, LocalMap, MapLink))
@@ -363,9 +364,12 @@ checkTileThing removeExits p@(Property name _value) = case name of
         suggestProperty $ Property "jitsiTrigger" "onaction"
 
         -- prevents namespace clashes for jitsi room names
-        unless ("shared" `isPrefixOf` jitsiRoom) $ do
+        if not ("shared" `isPrefixOf` jitsiRoom) then do
           assemblyname <- lintConfig configAssemblyTag
           setProperty "jitsiRoom" (assemblyname <> "-" <> jitsiRoom)
+          offersJitsi (assemblyname <> "-" <> jitsiRoom)
+        else
+          offersJitsi jitsiRoom
     "jitsiTrigger" -> do
       isString p
       unlessHasProperty "jitsiTriggerMessage"
@@ -430,7 +434,7 @@ checkTileThing removeExits p@(Property name _value) = case name of
                    complain $
                      "Old-Style inter-repository links (using {<placeholder>}) \
                      \cannot be used at "<>eventslug<>"; please use world:// \
-                     \instead (see https://di.c3voc.de/howto:world)."
+                     \instead (see the howto)."
                | ext == "tmx" ->
                    complain "Cannot use .tmx map format; use Tiled's json export instead."
                | ext /= "json" ->

lib/Types.hs

@@ -54,8 +54,8 @@ instance HasArguments Level where
 
 -- | a hint comes with an explanation (and a level), or is a dependency
 -- (in which case it'll be otherwise treated as an info hint)
-data Lint = Depends Dep | Offers Text | Lint Hint | Badge Badge | CW [Text]
-  deriving (Ord, Eq, Generic, ToJSONKey)
+data Lint = Depends Dep | Offers Text | Lint Hint | Badge Badge | CW [Text] | Jitsi Text
+  deriving (Ord, Eq, Generic)
 
 data Dep = Local RelPath | Link Text | MapLink Text | LocalMap RelPath
   deriving (Generic, Ord, Eq, NFData)
@@ -78,35 +78,35 @@ lintLevel _        = Info
 lintsToHints :: [Lint] -> [Hint]
 lintsToHints = mapMaybe (\case {Lint hint -> Just hint ; _ -> Nothing})
 
-instance PrettyPrint Lint where
-  prettyprint (Lint  Hint { hintMsg, hintLevel } ) =
-    "  " <> show hintLevel <> ": " <> hintMsg
-  prettyprint (Depends dep) =
-    "  Info: found dependency: " <> prettyprint dep
-  prettyprint (Offers dep) =
-    "  Info: map offers entrypoint " <> prettyprint dep
-  prettyprint (Badge _) =
-    "  Info: found a badge."
-  prettyprint (CW cws) =
-    "  CWs: " <> show cws
+-- instance PrettyPrint Lint where
+--   prettyprint (Lint  Hint { hintMsg, hintLevel } ) =
+--     "  " <> show hintLevel <> ": " <> hintMsg
+--   prettyprint (Depends dep) =
+--     "  Info: found dependency: " <> prettyprint dep
+--   prettyprint (Offers dep) =
+--     "  Info: map offers entrypoint " <> prettyprint dep
+--   prettyprint (Badge _) =
+--     "  Info: found a badge."
+--   prettyprint (CW cws) =
+--     "  CWs: " <> show cws
 
 instance PrettyPrint Hint where
   prettyprint (Hint level msg) = "  " <> show level <> ": " <> msg
 
-instance ToJSON Lint where
-  toJSON (Lint h) = toJSON h
-  toJSON (Depends dep) = A.object
-    [ "msg" .= prettyprint dep
-    , "level" .= A.String "Dependency Info" ]
-  toJSON (Offers l) = A.object
-    [ "msg" .= prettyprint l
-    , "level" .= A.String "Entrypoint Info" ]
-  toJSON (Badge _) = A.object
-    [ "msg" .= A.String "found a badge"
-    , "level" .= A.String "Badge Info"]
-  toJSON (CW cws) = A.object
-    [ "msg" .= A.String "Content Warning"
-    , "level" .= A.String "CW Info" ]
+-- instance ToJSON Lint where
+--   toJSON (Lint h) = toJSON h
+--   toJSON (Depends dep) = A.object
+--     [ "msg" .= prettyprint dep
+--     , "level" .= A.String "Dependency Info" ]
+--   toJSON (Offers l) = A.object
+--     [ "msg" .= prettyprint l
+--     , "level" .= A.String "Entrypoint Info" ]
+--   toJSON (Badge _) = A.object
+--     [ "msg" .= A.String "found a badge"
+--     , "level" .= A.String "Badge Info"]
+--   toJSON (CW cws) = A.object
+--     [ "msg" .= A.String "Content Warning"
+--     , "level" .= A.String "CW Info" ]
 
 instance ToJSON Hint where
   toJSON (Hint l m) = A.object

lib/Util.hs

@@ -15,8 +15,8 @@ import           Universum
 import           Data.Aeson as Aeson
 import qualified Data.Set   as S
 import qualified Data.Text  as T
-import           Data.Tiled (Layer (layerData), PropertyValue (..),
-                             Tileset (tilesetName), layerName, mkTiledId)
+import           Data.Tiled (Layer, PropertyValue (..), Tileset (tilesetName),
+                             layerName)
 
 -- | helper function to create proxies
 mkProxy :: a -> Proxy a

lib/WriteRepo.hs

@@ -18,8 +18,8 @@ import           Paths                  (normalise)
 import           System.Directory.Extra (copyFile, createDirectoryIfMissing,
                                          doesDirectoryExist)
 import           System.Exit            (ExitCode (..))
-import           System.FilePath        (takeDirectory)
 import qualified System.FilePath        as FP
+import           System.FilePath        (takeDirectory)
 import           System.FilePath.Posix  ((</>))
 import           Types                  (Dep (Local))