Skip to content
Snippets Groups Projects

Compare revisions

Changes are shown as if the source revision was being merged into the target revision. Learn more about comparing revisions.

Source

Select target project
No results found

Target

Select target project
No results found
Show changes
Commits on Source (15)
Hide whitespace changes
Inline Side-by-side
Showing
with 206 additions and 470 deletions
.gitlab-ci.yml
View file @ a4461ce5
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
View file @ a4461ce5
......@@ -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
View file @ a4461ce5
......@@ -12,7 +12,7 @@
},
{
"scope" : [ "script" ],
"allowed" : [ "scripts.world.di.c3voc.de" ]
"allowed" : [ "example.org" ]
}]
}
}
config.toml
View file @ a4461ce5
......@@ -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 deleted 100644 → 0
View file @ d3dcb5f4
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 deleted 100644 → 0
View file @ d3dcb5f4
{-# 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 deleted 100644 → 0
View file @ d3dcb5f4
{-# 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 deleted 100644 → 0
View file @ d3dcb5f4
{-# 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
View file @ a4461ce5
{ 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 deleted 100644 → 0
View file @ d3dcb5f4
{ 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 0 → 100644
View file @ a4461ce5
{
"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 0 → 100644
View file @ a4461ce5
{
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
View file @ a4461ce5
......@@ -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
View file @ a4461ce5
......@@ -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
View file @ a4461ce5
......@@ -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
View file @ a4461ce5
......@@ -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
View file @ a4461ce5
......@@ -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
View file @ a4461ce5
......@@ -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
View file @ a4461ce5
......@@ -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
View file @ a4461ce5
......@@ -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))
......

Impressum - Datenschutzerklärung