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 (71)
Expand all Hide whitespace changes
Inline Side-by-side
Showing
with 1942 additions and 439 deletions
.gitignore
View file @ d3dcb5f4
dist-newstyle/* dist-newstyle/*
.stack-work .stack-work
walint.cabal
result*
.hlint.yaml 0 → 100644
View file @ d3dcb5f4
This diff is collapsed.
Readme.md
View file @ d3dcb5f4
# walint: lint & adjust workadventure maps # walint: lint & adjust workadventure maps
`walint` is intended as a simple linter that will check workadventure maps for ### Overview & Components
common errors, such as non-existent map entrypoints or missing asset files, and
additionally suggest changes to improve accessability.
Optionally, it can also *adjust* maps — e.g. to automatically insert property `walint` is intended as a linter for workadventure maps that checks for common
values or help enforce an event's map policies — and then write them out again, errors (such as non-existent map entrypoints or missing asset files) and makes
copying all needed assets and minifying the map's json. This is used to simulate suggestions to improve accessability.
a `bbbRoom` property (via `openWebsite`), collect and remove badge tokens before
maps are published, and to resolve special-schema URIs (e.g. `world://`). 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 ## Installing
...@@ -25,7 +34,7 @@ running `ldd walint` and see if anything is marked as not found, then install it ...@@ -25,7 +34,7 @@ running `ldd walint` and see if anything is marked as not found, then install it
### Build using stack ### Build using stack
This uses a lockfile to pin versions of dependencies (as well as `ghc`, the haskell 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 Then just run
...@@ -34,8 +43,8 @@ stack build ...@@ -34,8 +43,8 @@ stack build
``` ```
If you lack `ghc` in the correct version and don't know how to install it, you can 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 pass it `--install-ghc` to take care of that for you (note that on NixOS, `stack` may
automatically use a fitting `ghc` derivation if it finds one). use a fitting `ghc` derivation if it finds one, even without `--install-ghc`).
To install into your `$PATH`, use To install into your `$PATH`, use
...@@ -50,25 +59,11 @@ stack run -- walint [options as normal] ...@@ -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 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 ### Build using cabal
Note that this does not pin dependencies, and `walint` currently does not even You can, but probably should not. Beware of older Aeson versions!
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.
## Usage ## Usage
``` sh ``` sh
...@@ -136,10 +131,8 @@ For now there are three types of such rules: ...@@ -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 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!) (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 There are currently three possible scopes: `map` applies to tiled map links
(i.e. `exitUrl`), `website` to `openWebsite`, `audio` to `playAudio`, and (i.e. `exitUrl`), `website` to `openWebsite`, `audio` to `playAudio`.
`bbb` to Big Blue Button rooms (though that last one may be changed again,
depending on the bbb deployment in use).
## Output ## Output
......
config.json
View file @ d3dcb5f4
...@@ -5,21 +5,14 @@ ...@@ -5,21 +5,14 @@
"AllowScripts":false, "AllowScripts":false,
"MaxLintLevel":"Warning", "MaxLintLevel":"Warning",
"DontCopyAssets":false, "DontCopyAssets":false,
"UriSchemas": [ "UriSchemas": {
["https", { "https:": [
"scope" : ["website"], {
"allowed" : ["media.ccc.de", "streaming.media.ccc.de", "static.rc3.world", "cdn.c3voc.de", "pretalx.c3voc.de"], "scope" : [ "website", "audio" ]
"blocked" : ["blocked.com"], },
"prefix" : "https:\/\/rc3.world\/2021\/wa_dereferrer\/" {
}], "scope" : [ "script" ],
["https", { "allowed" : [ "scripts.world.di.c3voc.de" ]
"scope" : ["audio"], }]
"allowed" : ["cdn.c3voc.de", "media.ccc.de", "streaming.media.ccc.de", "static.rc3.world", "live.dort.c3voc.de"] }
}],
["world", {
"scope" : ["map"],
"substs" : {
}
}]
]
} }
config.toml 0 → 100644
View file @ d3dcb5f4
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 0 → 100644
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 0 → 100644
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 0 → 100644
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 0 → 100644
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 0 → 100644
View file @ d3dcb5f4
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 0 → 100644
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;
}
lib/Badges.hs
View file @ d3dcb5f4
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
-- | module defining Badge types and utility functions -- | module defining Badge types and utility functions
module Badges where module Badges where
import Universum
import Data.Aeson (Options (fieldLabelModifier, sumEncoding), import Data.Aeson (Options (fieldLabelModifier, sumEncoding),
SumEncoding (UntaggedValue), ToJSON (toJSON), SumEncoding (UntaggedValue), ToJSON (toJSON),
defaultOptions, genericToJSON, (.=)) defaultOptions, genericToJSON, (.=))
import qualified Data.Aeson as A import qualified Data.Aeson as A
import Data.Char (toLower) import Data.Char (toLower)
import Data.Text (Text)
import GHC.Generics (Generic)
import Text.Regex.TDFA ((=~)) import Text.Regex.TDFA ((=~))
...@@ -27,10 +29,10 @@ data BadgeArea = ...@@ -27,10 +29,10 @@ data BadgeArea =
, areaWidth :: Double , areaWidth :: Double
, areaHeight :: Double , areaHeight :: Double
} }
deriving (Ord, Eq, Generic, Show) deriving (Ord, Eq, Generic, Show, NFData)
newtype BadgeToken = BadgeToken Text newtype BadgeToken = BadgeToken Text
deriving (Eq, Ord, Show) deriving newtype (Eq, Ord, Show, NFData)
instance ToJSON BadgeArea where instance ToJSON BadgeArea where
toJSON = genericToJSON defaultOptions toJSON = genericToJSON defaultOptions
...@@ -46,7 +48,7 @@ parseToken text = if text =~ ("^[a-zA-Z0-9]{50}$" :: Text) ...@@ -46,7 +48,7 @@ parseToken text = if text =~ ("^[a-zA-Z0-9]{50}$" :: Text)
else Nothing else Nothing
data Badge = Badge BadgeToken BadgeArea data Badge = Badge BadgeToken BadgeArea
deriving (Ord, Eq, Generic, Show) deriving (Ord, Eq, Generic, Show, NFData)
instance ToJSON Badge where instance ToJSON Badge where
toJSON (Badge token area) = A.object $ case area of toJSON (Badge token area) = A.object $ case area of
......
lib/CheckDir.hs
View file @ d3dcb5f4
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
-- | Module that contains high-level checking for an entire directory -- | Module that contains high-level checking for an entire directory
module CheckDir (recursiveCheckDir, DirResult(..), resultIsFatal) where module CheckDir ( maximumLintLevel
, recursiveCheckDir
import CheckMap (MapResult (..), loadAndLintMap) , DirResult (..)
import Control.Monad (void) , MissingAsset(..)
, MissingDep(..)
, resultIsFatal
,shrinkDirResult) where
import Universum hiding (Set)
import CheckMap (MapResult (..), Optional,
ResultKind (..), loadAndLintMap,
shrinkMapResult)
import Control.Monad.Extra (mapMaybeM) import Control.Monad.Extra (mapMaybeM)
import Data.Aeson (ToJSON, (.=)) import Data.Aeson (ToJSON, (.=))
import qualified Data.Aeson as A import qualified Data.Aeson as A
import Data.Bifunctor (first)
import Data.Foldable (fold)
import Data.Functor ((<&>))
import Data.List (partition) import Data.List (partition)
import Data.Map (Map, elems, keys)
import qualified Data.Map as M import qualified Data.Map as M
import Data.Map.Strict (mapKeys, mapWithKey, (\\)) import Data.Map.Strict (mapKeys, mapWithKey, (\\))
import Data.Maybe (isJust, mapMaybe) import Data.Text (isInfixOf)
import Data.Text (Text, isInfixOf)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Tiled (Tiledmap)
import Dirgraph (graphToDot, invertGraph, resultToGraph, import Dirgraph (graphToDot, invertGraph, resultToGraph,
takeSubGraph, unreachableFrom) takeSubGraph, unreachableFrom)
import GHC.Generics (Generic) import GHC.Generics (Generic)
...@@ -33,7 +42,7 @@ import System.Directory.Extra (doesFileExist) ...@@ -33,7 +42,7 @@ import System.Directory.Extra (doesFileExist)
import System.FilePath (splitPath, (</>)) import System.FilePath (splitPath, (</>))
import qualified System.FilePath as FP import qualified System.FilePath as FP
import System.FilePath.Posix (takeDirectory) import System.FilePath.Posix (takeDirectory)
import Text.Dot (Dot, showDot) import Text.Dot (showDot)
import Types (Dep (Local, LocalMap), Hint (Hint), import Types (Dep (Local, LocalMap), Hint (Hint),
Level (..), hintLevel) Level (..), hintLevel)
import Util (PrettyPrint (prettyprint), ellipsis) import Util (PrettyPrint (prettyprint), ellipsis)
...@@ -48,29 +57,39 @@ listFromSet :: Set a -> [a] ...@@ -48,29 +57,39 @@ listFromSet :: Set a -> [a]
listFromSet = map fst . M.toList listFromSet = map fst . M.toList
-- | Result of linting an entire directory / repository -- | Result of linting an entire directory / repository
data DirResult = DirResult data DirResult (complete :: ResultKind) = DirResult
{ dirresultMaps :: Map FilePath MapResult { dirresultMaps :: Map FilePath (MapResult complete)
-- ^ all maps of this respository, by (local) filepath -- ^ all maps of this respository, by (local) filepath
, dirresultDeps :: [MissingDep] , dirresultDeps :: [MissingDep]
-- ^ all dependencies to things outside this repository -- ^ all dependencies to things outside this repository
, dirresultMissingAssets :: [MissingAsset] , dirresultMissingAssets :: [MissingAsset]
-- ^ entrypoints of maps which are referred to but missing -- ^ entrypoints of maps which are referred to but missing
, dirresultGraph :: Dot () , dirresultGraph :: Text
} deriving (Generic) } deriving (Generic)
instance NFData (Optional a (Maybe Tiledmap)) => NFData (DirResult a)
data MissingDep = MissingDep data MissingDep = MissingDep
{ depFatal :: Maybe Bool { depFatal :: Maybe Bool
, entrypoint :: Text , entrypoint :: Text
, neededBy :: [FilePath] , neededBy :: [FilePath]
} deriving (Generic, ToJSON) } deriving (Generic, ToJSON, NFData)
-- | Missing assets are the same thing as missing dependencies, -- | Missing assets are the same thing as missing dependencies,
-- but should not be confused (and also serialise differently -- but should not be confused (and also serialise differently
-- to json) -- to json)
newtype MissingAsset = MissingAsset MissingDep 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? -- | given this config, should the result be considered to have failed?
resultIsFatal :: LintConfig' -> DirResult -> Bool resultIsFatal :: LintConfig' -> DirResult Full -> Bool
resultIsFatal config res = resultIsFatal config res =
not (null (dirresultMissingAssets res) || not (any (isJust . depFatal) (dirresultDeps res))) not (null (dirresultMissingAssets res) || not (any (isJust . depFatal) (dirresultDeps res)))
|| maximumLintLevel res > configMaxLintLevel config || maximumLintLevel res > configMaxLintLevel config
...@@ -78,11 +97,11 @@ resultIsFatal config res = ...@@ -78,11 +97,11 @@ resultIsFatal config res =
-- | maximum lint level that was observed anywhere in any map. -- | maximum lint level that was observed anywhere in any map.
-- note that it really does go through all lints, so don't -- note that it really does go through all lints, so don't
-- call it too often -- call it too often
maximumLintLevel :: DirResult -> Level maximumLintLevel :: DirResult a -> Level
maximumLintLevel res maximumLintLevel res
| not (null (dirresultMissingAssets res)) = Fatal | not (null (dirresultMissingAssets res)) = Fatal
| otherwise = | otherwise =
(\t -> if null t then Info else maximum t) (maybe Info maximum . nonEmpty)
. map hintLevel . map hintLevel
. concatMap (\map -> keys (mapresultLayer map) . concatMap (\map -> keys (mapresultLayer map)
<> keys (mapresultTileset map) <> keys (mapresultTileset map)
...@@ -94,7 +113,7 @@ maximumLintLevel res ...@@ -94,7 +113,7 @@ maximumLintLevel res
instance ToJSON DirResult where instance ToJSON (DirResult a) where
toJSON res = A.object [ toJSON res = A.object [
"result" .= A.object "result" .= A.object
[ "missingDeps" .= dirresultDeps res [ "missingDeps" .= dirresultDeps res
...@@ -106,8 +125,7 @@ instance ToJSON DirResult where ...@@ -106,8 +125,7 @@ instance ToJSON DirResult where
. foldr aggregateSameResults [] . foldr aggregateSameResults []
. M.toList . M.toList
$ dirresultMaps res) $ dirresultMaps res)
-- unused in the hub, temporarily removed to make the output smaller , "exitGraph" .= dirresultGraph res
, "exitGraph" .= showDot (dirresultGraph res)
] ]
, "severity" .= maximumLintLevel res , "severity" .= maximumLintLevel res
, "mapInfo" .= fmap (\tm -> A.object [ "badges" .= mapresultBadges tm ]) , "mapInfo" .= fmap (\tm -> A.object [ "badges" .= mapresultBadges tm ])
...@@ -116,8 +134,8 @@ instance ToJSON DirResult where ...@@ -116,8 +134,8 @@ instance ToJSON DirResult where
where where
aggregateSameResults (path,res) acc = aggregateSameResults (path,res) acc =
case partition (\(_,res') -> res == res') acc of case partition (\(_,res') -> res == res') acc of
([],_) -> ([T.pack path], res):acc ([],_) -> ([toText path], res):acc
((paths,_):_,acc') -> (T.pack path:paths, res) : acc' ((paths,_):_,acc') -> (toText path:paths, res) : acc'
instance ToJSON MissingAsset where instance ToJSON MissingAsset where
toJSON (MissingAsset md) = A.object toJSON (MissingAsset md) = A.object
...@@ -126,7 +144,7 @@ instance ToJSON MissingAsset where ...@@ -126,7 +144,7 @@ instance ToJSON MissingAsset where
] ]
instance PrettyPrint (Level, DirResult) where instance PrettyPrint (Level, DirResult a) where
prettyprint (level, res) = prettyMapLints <> prettyMissingDeps prettyprint (level, res) = prettyMapLints <> prettyMissingDeps
where where
prettyMissingDeps = if not (null (dirresultDeps res)) prettyMissingDeps = if not (null (dirresultDeps res))
...@@ -134,9 +152,9 @@ instance PrettyPrint (Level, DirResult) where ...@@ -134,9 +152,9 @@ instance PrettyPrint (Level, DirResult) where
else "" else ""
prettyMapLints = T.concat prettyMapLints = T.concat
(map prettyLint $ M.toList $ dirresultMaps res) (map prettyLint $ M.toList $ dirresultMaps res)
prettyLint :: (FilePath, MapResult) -> Text prettyLint :: (FilePath, MapResult a) -> Text
prettyLint (p, lint) = prettyLint (p, lint) =
"\nin " <> T.pack p <> ":\n" <> prettyprint (level, lint) "\nin " <> toText p <> ":\n" <> prettyprint (level, lint)
instance PrettyPrint MissingDep where instance PrettyPrint MissingDep where
prettyprint (MissingDep _ f n) = prettyprint (MissingDep _ f n) =
...@@ -144,7 +162,7 @@ instance PrettyPrint MissingDep where ...@@ -144,7 +162,7 @@ instance PrettyPrint MissingDep where
<> prettyDependents <> "\n" <> prettyDependents <> "\n"
where where
prettyDependents = prettyDependents =
T.intercalate "," $ map T.pack n T.intercalate "," $ map toText n
-- | check an entire repository -- | check an entire repository
...@@ -154,7 +172,7 @@ recursiveCheckDir ...@@ -154,7 +172,7 @@ recursiveCheckDir
-- ^ the repository's prefix (i.e. path to its directory) -- ^ the repository's prefix (i.e. path to its directory)
-> FilePath -> FilePath
-- ^ the repository's entrypoint (filename of a map, from the repo's root) -- ^ the repository's entrypoint (filename of a map, from the repo's root)
-> IO DirResult -> IO (DirResult Full)
recursiveCheckDir config prefix root = do recursiveCheckDir config prefix root = do
maps <- recursiveCheckDir' config prefix [root] mempty maps <- recursiveCheckDir' config prefix [root] mempty
...@@ -169,7 +187,7 @@ recursiveCheckDir config prefix root = do ...@@ -169,7 +187,7 @@ recursiveCheckDir config prefix root = do
let maps' = flip mapWithKey maps $ \path res -> let maps' = flip mapWithKey maps $ \path res ->
if path `elem` nowayback if path `elem` nowayback
then res { mapresultGeneral = 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 : mapresultGeneral res
} }
else res else res
...@@ -179,7 +197,9 @@ recursiveCheckDir config prefix root = do ...@@ -179,7 +197,9 @@ recursiveCheckDir config prefix root = do
, dirresultMissingAssets = mAssets , dirresultMissingAssets = mAssets
, dirresultMaps = maps' , dirresultMaps = maps'
, dirresultGraph = , dirresultGraph =
graphToDot toText
. showDot
. graphToDot
. takeSubGraph 7 root . takeSubGraph 7 root
$ exitGraph $ exitGraph
} }
...@@ -187,9 +207,9 @@ recursiveCheckDir config prefix root = do ...@@ -187,9 +207,9 @@ recursiveCheckDir config prefix root = do
-- | Given a (partially) completed DirResult, check which local -- | Given a (partially) completed DirResult, check which local
-- maps are referenced but do not actually exist. -- maps are referenced but do not actually exist.
missingDeps :: FilePath -> Map FilePath MapResult -> [MissingDep] missingDeps :: FilePath -> Map FilePath (MapResult a) -> [MissingDep]
missingDeps entrypoint maps = 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 in M.foldMapWithKey (\f n -> [MissingDep (Just $ not ("#" `isInfixOf` f)) f n]) simple
where where
-- which maps are linked somewhere? -- which maps are linked somewhere?
...@@ -199,19 +219,19 @@ missingDeps entrypoint maps = ...@@ -199,19 +219,19 @@ missingDeps entrypoint maps =
(\path v -> map (, [path]) . mapMaybe (extractLocalDeps path) . mapresultDepends $ v) (\path v -> map (, [path]) . mapMaybe (extractLocalDeps path) . mapresultDepends $ v)
maps maps
where extractLocalDeps prefix = \case where extractLocalDeps prefix = \case
LocalMap name -> Just $ T.pack $ normaliseWithFrag prefix name LocalMap name -> Just $ toText $ normaliseWithFrag prefix name
_ -> Nothing _ -> Nothing
-- which are defined using startLayer? -- which are defined using startLayer?
defined :: Set Text defined :: Set Text
defined = setFromList defined = setFromList
$ M.foldMapWithKey $ M.foldMapWithKey
(\k v -> map ((T.pack k <> "#") <>) . mapresultProvides $ v) (\k v -> map ((toText k <> "#") <>) . mapresultProvides $ v)
maps maps
-- each map file is an entrypoint by itself -- 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 -- | 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 = missingAssets prefix maps =
mapM (fmap (fmap (fmap MissingAsset)) missingOfMap) (M.toList maps) <&> fold mapM (fmap (fmap (fmap MissingAsset)) missingOfMap) (M.toList maps) <&> fold
where missingOfMap (path, mapres) = mapMaybeM where missingOfMap (path, mapres) = mapMaybeM
...@@ -219,7 +239,7 @@ missingAssets prefix maps = ...@@ -219,7 +239,7 @@ missingAssets prefix maps =
let asset = normalise (takeDirectory path) relpath let asset = normalise (takeDirectory path) relpath
in doesFileExist (prefix </> asset) <&> in doesFileExist (prefix </> asset) <&>
\case True -> Nothing \case True -> Nothing
False -> Just $ MissingDep Nothing (T.pack asset) [path] False -> Just $ MissingDep Nothing (toText asset) [path]
_ -> pure Nothing) _ -> pure Nothing)
(mapresultDepends mapres) (mapresultDepends mapres)
...@@ -231,10 +251,10 @@ recursiveCheckDir' ...@@ -231,10 +251,10 @@ recursiveCheckDir'
-- ^ the repo's directory -- ^ the repo's directory
-> [FilePath] -> [FilePath]
-- ^ paths of maps yet to check -- ^ paths of maps yet to check
-> Map FilePath MapResult -> Map FilePath (MapResult Full)
-- ^ accumulator for map results -- ^ accumulator for map results
-> IO (Map FilePath MapResult) -> IO (Map FilePath (MapResult Full))
recursiveCheckDir' config prefix paths acc = do recursiveCheckDir' config prefix paths !acc = do
-- lint all maps in paths. The double fmap skips maps which cause IO errors -- lint all maps in paths. The double fmap skips maps which cause IO errors
-- (in which case loadAndLintMap returns Nothing); appropriate warnings will -- (in which case loadAndLintMap returns Nothing); appropriate warnings will
...@@ -242,7 +262,7 @@ recursiveCheckDir' config prefix paths acc = do ...@@ -242,7 +262,7 @@ recursiveCheckDir' config prefix paths acc = do
lints <- lints <-
let lintPath p = fmap (fmap (p,)) (loadAndLintMap config (prefix </> p) depth) let lintPath p = fmap (fmap (p,)) (loadAndLintMap config (prefix </> p) depth)
where depth = length (splitPath p) - 1 where depth = length (splitPath p) - 1
in mapMaybeM lintPath paths in mapMaybeM lintPath paths >>= evaluateNF
let mapdeps = setFromList (concatMap extractDeps lints) let mapdeps = setFromList (concatMap extractDeps lints)
......
lib/CheckMap.hs
View file @ d3dcb5f4
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-} {-# 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 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 Data.Aeson (ToJSON (toJSON))
import qualified Data.Aeson as A import qualified Data.Aeson as A
import Data.Aeson.Types ((.=)) import Data.Aeson.Types ((.=))
import Data.Functor ((<&>))
import Data.Map (Map, toList)
import qualified Data.Map as M import qualified Data.Map as M
import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Vector as V import qualified Data.Vector as V
import GHC.Generics (Generic)
import Badges (Badge) 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, import LintWriter (LintResult, invertLintResult,
resultToAdjusted, resultToBadges, resultToAdjusted, resultToBadges,
resultToDeps, resultToLints, resultToOffers, resultToDeps, resultToLints, resultToOffers,
runLintWriter) runLintWriter, resultToCWs)
import Properties (checkLayer, checkMap, checkTileset) import Properties (checkLayer, checkMap, checkTileset)
import System.FilePath (takeFileName) import System.FilePath (takeFileName)
import Tiled (Layer (layerLayers, layerName),
LoadResult (..),
Tiledmap (tiledmapLayers, tiledmapTilesets),
loadTiledmap)
import Types (Dep (MapLink), import Types (Dep (MapLink),
Hint (Hint, hintLevel, hintMsg), Level (..), Hint (Hint, hintLevel, hintMsg), Level (..),
lintsToHints) lintsToHints)
import Util (PrettyPrint (prettyprint), prettyprint) 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 -- | What this linter produces: lints for a single map
data MapResult = MapResult data MapResult (kind :: ResultKind) = MapResult
{ mapresultLayer :: Map Hint [Text] { mapresultLayer :: Map Hint [Text]
-- ^ lints that occurred in one or more layers -- ^ lints that occurred in one or more layers
, mapresultTileset :: Map Hint [Text] , mapresultTileset :: Map Hint [Text]
...@@ -49,16 +58,20 @@ data MapResult = MapResult ...@@ -49,16 +58,20 @@ data MapResult = MapResult
-- ^ (external and local) dependencies of this map -- ^ (external and local) dependencies of this map
, mapresultProvides :: [Text] , mapresultProvides :: [Text]
-- ^ entrypoints provided by this map (needed for dependency checking) -- ^ 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 -- ^ the loaded map, with adjustments by the linter
, mapresultBadges :: [Badge] , mapresultBadges :: [Badge]
-- ^ badges that can be found on this map -- ^ badges that can be found on this map
, mapresultCWs :: [Text]
-- ^ collected CWs that apply to this map
, mapresultGeneral :: [Hint] , mapresultGeneral :: [Hint]
-- ^ general-purpose lints that didn't fit anywhere else -- ^ general-purpose lints that didn't fit anywhere else
} deriving (Generic) } deriving (Generic)
instance NFData (Optional a (Maybe Tiledmap)) => NFData (MapResult a)
instance Eq MapResult where
instance Eq (MapResult a) where
a == b = a == b =
mapresultLayer a == mapresultLayer b && mapresultLayer a == mapresultLayer b &&
mapresultTileset a == mapresultTileset b && mapresultTileset a == mapresultTileset b &&
...@@ -66,7 +79,7 @@ instance Eq MapResult where ...@@ -66,7 +79,7 @@ instance Eq MapResult where
mapresultGeneral a == mapresultGeneral b mapresultGeneral a == mapresultGeneral b
instance ToJSON MapResult where instance ToJSON (MapResult a) where
toJSON res = A.object toJSON res = A.object
[ "layer" .= CollectedLints (mapresultLayer res) [ "layer" .= CollectedLints (mapresultLayer res)
, "tileset" .= CollectedLints (mapresultTileset res) , "tileset" .= CollectedLints (mapresultTileset res)
...@@ -84,40 +97,45 @@ instance ToJSON CollectedLints where ...@@ -84,40 +97,45 @@ instance ToJSON CollectedLints where
else cs else cs
shrinkMapResult :: MapResult Full -> MapResult Shrunk
shrinkMapResult !res = res { mapresultAdjusted = () }
-- | this module's raison d'être -- | this module's raison d'être
-- Lints the map at `path`, and limits local links to at most `depth` -- Lints the map at `path`, and limits local links to at most `depth`
-- layers upwards in the file hierarchy -- layers upwards in the file hierarchy
loadAndLintMap :: LintConfig' -> FilePath -> Int -> IO (Maybe MapResult) loadAndLintMap :: LintConfig' -> FilePath -> Int -> IO (Maybe (MapResult Full))
loadAndLintMap config path depth = loadTiledmap path <&> (\case loadAndLintMap config path depth = loadTiledmap path <&> \case
DecodeErr err -> Just (MapResult mempty mempty mempty mempty Nothing mempty Left err -> Just (MapResult mempty mempty mempty mempty Nothing mempty mempty
[ Hint Fatal . T.pack $ [ Hint Fatal . toText $
path <> ": Fatal: " <> err path <> ": Fatal: " <> err
]) ])
IOErr _ -> Nothing Right waMap ->
Loaded waMap -> Just (runLinter (takeFileName path == "main.json") config waMap depth)
Just (runLinter (takeFileName path == "main.json") config waMap depth))
-- | lint a loaded map -- | lint a loaded map
runLinter :: Bool -> LintConfig' -> Tiledmap -> Int -> MapResult runLinter :: Bool -> LintConfig' -> Tiledmap -> Int -> MapResult Full
runLinter isMain config tiledmap depth = MapResult runLinter isMain config@LintConfig{..} tiledmap depth = MapResult
{ mapresultLayer = invertThing layer { mapresultLayer = invertThing layer
, mapresultTileset = invertThing tileset , mapresultTileset = invertThing tileset
, mapresultGeneral = , 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) <> lintsToHints (resultToLints generalResult)
, mapresultDepends = resultToDeps generalResult , mapresultDepends = resultToDeps generalResult
<> layerDeps <> layerDeps
<> concatMap resultToDeps tileset <> concatMap resultToDeps tileset
, mapresultProvides = concatMap resultToOffers layer , mapresultProvides = concatMap resultToOffers layer
, mapresultAdjusted = Just adjustedMap , mapresultAdjusted = Just adjustedMap
, mapresultCWs = resultToCWs generalResult
, mapresultBadges = concatMap resultToBadges layer , mapresultBadges = concatMap resultToBadges layer
<> resultToBadges generalResult <> resultToBadges generalResult
} }
where where
linksLobby = \case linksLobby = \case
MapLink link -> "/@/rc3_21/lobby" `T.isPrefixOf` link MapLink link ->
|| configAssemblyTag config == "lobby" ("/@/"<>configEventSlug<>"/lobby") `T.isPrefixOf` link
_ -> False || configAssemblyTag == "lobby"
_ -> False
layerDeps = concatMap resultToDeps layer layerDeps = concatMap resultToDeps layer
layer = checkLayerRec config depth (V.toList $ tiledmapLayers tiledmap) layer = checkLayerRec config depth (V.toList $ tiledmapLayers tiledmap)
tileset = checkThing tiledmapTilesets checkTileset tileset = checkThing tiledmapTilesets checkTileset
...@@ -183,7 +201,7 @@ checkLayerRec config depth layers = ...@@ -183,7 +201,7 @@ checkLayerRec config depth layers =
-- human-readable lint output, e.g. for consoles -- human-readable lint output, e.g. for consoles
instance PrettyPrint (Level, MapResult) where instance PrettyPrint (Level, MapResult a) where
prettyprint (_, mapResult) = if complete == "" prettyprint (_, mapResult) = if complete == ""
then " all good!\n" else complete then " all good!\n" else complete
where where
...@@ -194,11 +212,10 @@ instance PrettyPrint (Level, MapResult) where ...@@ -194,11 +212,10 @@ instance PrettyPrint (Level, MapResult) where
-- | pretty-prints a collection of Hints, printing each -- | pretty-prints a collection of Hints, printing each
-- Hint only once, then a list of its occurences line-wrapped -- Hint only once, then a list of its occurences line-wrapped
-- to fit onto a decent-sized terminal -- to fit onto a decent-sized terminal
prettyLints :: (MapResult -> Map Hint [Text]) -> [Text] prettyLints :: (MapResult a -> Map Hint [Text]) -> [Text]
prettyLints getter = fmap prettyLints getter = fmap
(\(h, cs) -> prettyprint h (\(h, cs) -> prettyprint h
<> "\n (in " <> "\n (in "
-- foldl :: ((length of current line, acc) -> next ctxt -> list) -> ...
<> snd (foldl (\(l,a) c -> case l of <> snd (foldl (\(l,a) c -> case l of
0 -> (T.length c, c) 0 -> (T.length c, c)
_ | l < 70 -> (l+2+T.length c, a <> ", " <> c) _ | l < 70 -> (l+2+T.length c, a <> ", " <> c)
...@@ -206,7 +223,7 @@ instance PrettyPrint (Level, MapResult) where ...@@ -206,7 +223,7 @@ instance PrettyPrint (Level, MapResult) where
) )
(0, "") cs) (0, "") cs)
<> ")\n") <> ")\n")
(toList . getter $ mapResult) (M.toList . getter $ mapResult)
prettyGeneral :: [Text] prettyGeneral :: [Text]
prettyGeneral = map prettyGeneral = map
......
lib/Dirgraph.hs
View file @ d3dcb5f4
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
-- | Simple directed graphs, for dependency checking -- | Simple directed graphs, for dependency checking
module Dirgraph where module Dirgraph where
import Universum
import CheckMap (MapResult (mapresultDepends)) import CheckMap (MapResult (mapresultDepends))
import Control.Monad (forM_, unless) import Data.Map.Strict (mapMaybeWithKey, mapWithKey, traverseWithKey)
import Data.Functor ((<&>)) import qualified Data.Map.Strict as M
import Data.Map.Strict (Map, mapMaybeWithKey, mapWithKey, import Data.Set ((\\))
traverseMaybeWithKey, traverseWithKey) import qualified Data.Set as S
import qualified Data.Map.Strict as M import Paths (normalise)
import Data.Maybe (fromMaybe) import Text.Dot (Dot, (.->.))
import Data.Set (Set, (\\)) import qualified Text.Dot as D
import qualified Data.Set as S import Types (Dep (LocalMap))
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)
-- | a simple directed graph -- | a simple directed graph
type Graph a = Map a (Set a) type Graph a = Map a (Set a)
...@@ -29,18 +24,16 @@ nodes :: Graph a -> Set a ...@@ -29,18 +24,16 @@ nodes :: Graph a -> Set a
nodes = M.keysSet nodes = M.keysSet
-- | simple directed graph of exits -- | simple directed graph of exits
resultToGraph :: Map FilePath MapResult -> Graph FilePath resultToGraph :: Map FilePath (MapResult a) -> Graph FilePath
resultToGraph = mapWithKey (\p r -> S.fromList resultToGraph = fmap (S.fromList . mapMaybe onlyLocalMaps . mapresultDepends)
. mapMaybe (onlyLocalMaps (takeDirectory p)) where onlyLocalMaps = \case
. mapresultDepends $ r) LocalMap path -> Just (normalise "" path)
where onlyLocalMaps prefix = \case
LocalMap path -> Just (FP.normalise (prefix </> normalise "" path))
_ -> Nothing _ -> Nothing
-- | invert edges of a directed graph -- | invert edges of a directed graph
invertGraph :: (Eq a, Ord a) => Graph a -> Graph a invertGraph :: (Eq a, Ord a) => Graph a -> Graph a
invertGraph graph = mapWithKey collectFroms graph 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 select to from elems = if to `elem` elems then Just from else Nothing
-- | all nodes reachable from some entrypoint -- | all nodes reachable from some entrypoint
...@@ -75,7 +68,7 @@ takeSubGraph i start graph ...@@ -75,7 +68,7 @@ takeSubGraph i start graph
graphToDot :: Graph FilePath -> Dot () graphToDot :: Graph FilePath -> Dot ()
graphToDot graph = do graphToDot graph = do
main <- D.node [("label","main.json")] main <- D.node [("label","main.json")]
nodes' <- traverseMaybeWithKey nodes' <- M.traverseMaybeWithKey
(\name edges -> if name /= "main.json" (\name edges -> if name /= "main.json"
then D.node [("label",name)] <&> (, edges) <&> Just then D.node [("label",name)] <&> (, edges) <&> Just
else pure Nothing else pure Nothing
......
lib/LayerData.hs
View file @ d3dcb5f4
...@@ -2,13 +2,13 @@ ...@@ -2,13 +2,13 @@
module LayerData where module LayerData where
import Universum hiding (maximum, uncons)
import Control.Monad.Zip (mzipWith) import Control.Monad.Zip (mzipWith)
import Data.Set (Set, insert) import Data.Set (insert)
import Data.Text (Text) import Data.Tiled (GlobalId (unGlobalId), Layer (..))
import qualified Data.Text as T import Data.Vector (maximum, uncons)
import Data.Vector (Vector, uncons) import qualified Text.Show as TS
import Tiled (GlobalId (unGlobalId), Layer (..))
import Util (PrettyPrint (..)) import Util (PrettyPrint (..))
-- | A collision between two layers of the given names. -- | A collision between two layers of the given names.
...@@ -22,8 +22,8 @@ instance Eq Collision where ...@@ -22,8 +22,8 @@ instance Eq Collision where
instance PrettyPrint Collision where instance PrettyPrint Collision where
prettyprint (Collision (a,b)) = a <> " and " <> b prettyprint (Collision (a,b)) = a <> " and " <> b
instance Show Collision where instance TS.Show Collision where
show c = T.unpack $ prettyprint c show c = toString $ prettyprint c
-- | Finds pairwise tile collisions between the given layers. -- | Finds pairwise tile collisions between the given layers.
layerOverlaps :: Vector Layer -> Set Collision layerOverlaps :: Vector Layer -> Set Collision
......
lib/LintConfig.hs
View file @ d3dcb5f4
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
-- | Module that deals with handling config options -- | Module that deals with handling config options
module LintConfig where module LintConfig (LintConfig(..), LintConfig', ConfigKind (..), patchConfig,stuffConfig,feedConfig) where
import Control.Monad.Identity (Identity) import Universum
import Data.Aeson (FromJSON (parseJSON), Options (..),
defaultOptions, eitherDecode) import Data.Aeson (FromJSON (parseJSON), Options (..),
import Data.Aeson.Types (genericParseJSON) defaultOptions, eitherDecode)
import qualified Data.ByteString.Char8 as C8 import Data.Aeson.Types (genericParseJSON)
import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString.Char8 as C8
import qualified Data.Map.Strict as M import qualified Data.ByteString.Lazy as LB
import Data.Text (Text) import qualified Data.Map.Strict as M
import GHC.Generics (Generic (Rep, from, to), K1 (..), import GHC.Generics (Generic (Rep, from, to), K1 (..),
M1 (..), (:*:) (..)) M1 (..), (:*:) (..))
import Types (Level) import Types (Level)
import Uris (SchemaSet, import Uris (SchemaSet,
Substitution (DomainSubstitution)) Substitution (DomainSubstitution))
import WithCli (Proxy (..)) import WithCli.Pure (Argument (argumentType, parseArgument))
import WithCli.Pure (Argument (argumentType, parseArgument))
type family HKD f a where
HKD Identity a = a data ConfigKind = Complete | Basic | Skeleton | Patch
HKD f a = f a
-- | a field that must be given in configs for both server & standalone linter
data LintConfig f = LintConfig type family ConfigField (f::ConfigKind) a where
{ configScriptInject :: HKD f (Maybe Text) 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 -- ^ Link to Script that should be injected
, configAssemblyTag :: HKD f Text , configAssemblyTag :: WorldField f Text
-- ^ Assembly name (used for jitsiRoomAdminTag) -- ^ 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) -- ^ 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 -- ^ 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) -- ^ Don't copy map assets (mostly useful for development)
, configAllowScripts :: HKD f Bool , configAllowScripts :: ConfigField f Bool
-- ^ Allow defining custom scripts in maps -- ^ Allow defining custom scripts in maps
, configUriSchemas :: HKD f SchemaSet , configUriSchemas :: ConfigField f SchemaSet
} deriving (Generic) } deriving (Generic)
type LintConfig' = LintConfig Identity type LintConfig' = LintConfig Complete
-- TODO: should probably find a way to write these constraints nicer ... deriving instance Show (LintConfig Complete)
deriving instance deriving instance Show (LintConfig Skeleton)
( Show (HKD a (Maybe Text)) deriving instance Show (LintConfig Patch)
, Show (HKD a Text) instance NFData (LintConfig Basic)
, Show (HKD a Level)
, Show (HKD a [Text])
, Show (HKD a Bool)
, Show (HKD a SchemaSet)
)
=> Show (LintConfig a)
aesonOptions :: Options aesonOptions :: Options
aesonOptions = defaultOptions aesonOptions = defaultOptions
...@@ -68,23 +83,13 @@ aesonOptions = defaultOptions ...@@ -68,23 +83,13 @@ aesonOptions = defaultOptions
, fieldLabelModifier = drop 6 , fieldLabelModifier = drop 6
} }
instance instance FromJSON (LintConfig Complete) where
( FromJSON (HKD a (Maybe Text)) parseJSON = genericParseJSON aesonOptions
, 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
-- need to define this one extra, since Aeson will not make instance FromJSON (LintConfig Patch) where
-- Maybe fields optional if the type isn't given explicitly. parseJSON = genericParseJSON aesonOptions
--
-- Whoever said instances had confusing semantics? instance FromJSON (LintConfig Basic) where
instance {-# Overlapping #-} FromJSON (LintConfig Maybe) where
parseJSON = genericParseJSON aesonOptions parseJSON = genericParseJSON aesonOptions
...@@ -118,30 +123,66 @@ instance GPatch i o ...@@ -118,30 +123,66 @@ instance GPatch i o
-- abstract, I just wanted to play around with higher kinded types for -- abstract, I just wanted to play around with higher kinded types for
-- a bit. -- a bit.
patch :: patch ::
( Generic (f Maybe) ( Generic (f Patch)
, Generic (f Identity) , Generic (f Complete)
, GPatch (Rep (f Identity)) , GPatch (Rep (f Complete))
(Rep (f Maybe)) (Rep (f Patch))
) )
=> f Identity => f Complete
-> f Maybe -> f Patch
-> f Identity -> f Complete
patch x y = to (gappend (from x) (from y)) patch x y = to (gappend (from x) (from y))
patchConfig :: LintConfig Identity -> Maybe (LintConfig Maybe) -> LintConfig Identity patchConfig
patchConfig config p = config' :: LintConfig Complete
{ configUriSchemas = ("world", assemblysubsts) : configUriSchemas config'} -> Maybe (LintConfig Patch)
where config' = case p of -> LintConfig Complete
Just p -> patch config p patchConfig config p = expandWorlds config'
Nothing -> config where
assemblysubsts = config' = case p of
DomainSubstitution (M.fromList generated) scope Just p -> patch config p
where generated = (\slug -> (slug, "/@/rc3_21/"<>slug)) <$> configAssemblies config' Nothing -> config
scope = (\(DomainSubstitution _ s) -> s)
. snd . head
. filter ((==) "world" . fst) -- | feed a basic server config
$ configUriSchemas 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 instance (FromJSON (LintConfig a)) => Argument (LintConfig a) where
parseArgument str = parseArgument str =
......
lib/LintWriter.hs
View file @ d3dcb5f4
...@@ -40,23 +40,17 @@ module LintWriter ...@@ -40,23 +40,17 @@ module LintWriter
, lintConfig , lintConfig
-- * adjust the linter's context -- * adjust the linter's context
, adjust , adjust
) where ,offersCWs,resultToCWs) where
import Data.Text (Text) import Universum
import Badges (Badge)
import Control.Monad.State (MonadState (put), StateT, modify) import Badges (Badge)
import Control.Monad.Trans.Reader (Reader, asks, runReader) import Data.Map (fromListWith)
import Control.Monad.Trans.State (get, runStateT) import Data.Tiled.Abstract (HasName (getName))
import Control.Monad.Writer.Lazy (lift) import LintConfig (LintConfig')
import Data.Bifunctor (Bifunctor (second)) import Types (Dep, Hint, Level (..), Lint (..), hint,
import Data.Map (Map, fromListWith) lintsToHints)
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)
-- | A monad modelling the main linter features -- | A monad modelling the main linter features
...@@ -109,7 +103,7 @@ zoom embed extract operation = do ...@@ -109,7 +103,7 @@ zoom embed extract operation = do
-- | "invert" a linter's result, grouping lints by their messages -- | "invert" a linter's result, grouping lints by their messages
invertLintResult :: HasName ctxt => LintResult ctxt -> Map Hint [Text] invertLintResult :: HasName ctxt => LintResult ctxt -> Map Hint [Text]
invertLintResult (LinterState (lints, ctxt)) = 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 :: LintResult a -> [Dep]
resultToDeps (LinterState (lints,_)) = mapMaybe lintToDep lints resultToDeps (LinterState (lints,_)) = mapMaybe lintToDep lints
...@@ -128,6 +122,11 @@ resultToBadges (LinterState a) = mapMaybe lintToBadge $ fst a ...@@ -128,6 +122,11 @@ resultToBadges (LinterState a) = mapMaybe lintToBadge $ fst a
where lintToBadge (Badge badge) = Just badge where lintToBadge (Badge badge) = Just badge
lintToBadge _ = Nothing 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 -- | convert a lint result into a flat list of lints
resultToLints :: LintResult a -> [Lint] resultToLints :: LintResult a -> [Lint]
resultToLints (LinterState res) = fst res resultToLints (LinterState res) = fst res
...@@ -158,6 +157,8 @@ offersEntrypoint text = tell' $ Offers text ...@@ -158,6 +157,8 @@ offersEntrypoint text = tell' $ Offers text
offersBadge :: Badge -> LintWriter a offersBadge :: Badge -> LintWriter a
offersBadge badge = tell' $ Badge badge offersBadge badge = tell' $ Badge badge
offersCWs :: [Text] -> LintWriter a
offersCWs = tell' . CW
-- | get the context as it was initially, without any modifications -- | get the context as it was initially, without any modifications
......
lib/Paths.hs
View file @ d3dcb5f4
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
...@@ -5,18 +7,21 @@ ...@@ -5,18 +7,21 @@
-- I just hope you are running this on some kind of Unix -- I just hope you are running this on some kind of Unix
module Paths where module Paths where
import Data.Text (Text, isPrefixOf) import Universum
import qualified Universum.Unsafe as Unsafe
import qualified Data.Text as T import qualified Data.Text as T
import System.FilePath (splitPath) import System.FilePath (splitPath)
import System.FilePath.Posix ((</>)) import System.FilePath.Posix ((</>))
import Text.Regex.TDFA import Text.Regex.TDFA
import Util (PrettyPrint (prettyprint)) import Util (PrettyPrint (prettyprint))
-- | a normalised path: a number of "upwards" steps, and -- | a normalised path: a number of "upwards" steps, and
-- a path without any . or .. in it. Also possibly a -- a path without any . or .. in it. Also possibly a
-- fragment, mostly for map links. -- fragment, mostly for map links.
data RelPath = Path Int Text (Maybe Text) data RelPath = Path Int Text (Maybe Text)
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord, NFData, Generic)
...@@ -32,9 +37,9 @@ parsePath :: Text -> PathResult ...@@ -32,9 +37,9 @@ parsePath :: Text -> PathResult
parsePath text = parsePath text =
if | T.isInfixOf "{{" text || T.isInfixOf "}}" text -> PathVarsDisallowed if | T.isInfixOf "{{" text || T.isInfixOf "}}" text -> PathVarsDisallowed
| rest =~ ("^([^/]*[^\\./]/)*[^/]*[^\\./]$" :: Text) -> OkRelPath (Path up path fragment) | rest =~ ("^([^/]*[^\\./]/)*[^/]*[^\\./]$" :: Text) -> OkRelPath (Path up path fragment)
| "/_/" `isPrefixOf` text -> UnderscoreMapLink | "/_/" `T.isPrefixOf` text -> UnderscoreMapLink
| "/@/" `isPrefixOf` text -> AtMapLink | "/@/" `T.isPrefixOf` text -> AtMapLink
| "/" `isPrefixOf` text -> AbsolutePath | "/" `T.isPrefixOf` text -> AbsolutePath
| otherwise -> NotAPath | otherwise -> NotAPath
where where
(_, prefix, rest, _) = (_, prefix, rest, _) =
...@@ -43,10 +48,10 @@ parsePath text = ...@@ -43,10 +48,10 @@ parsePath text =
up = length . filter (".." ==) . T.splitOn "/" $ prefix up = length . filter (".." ==) . T.splitOn "/" $ prefix
parts = T.splitOn "#" rest parts = T.splitOn "#" rest
-- `head` is unsafe, but splitOn will always produce lists with at least one element -- `head` is unsafe, but splitOn will always produce lists with at least one element
path = head parts path = Unsafe.head parts
fragment = if length parts >= 2 fragment = case nonEmpty parts of
then Just $ T.concat $ tail parts Nothing -> Nothing
else Nothing Just p -> Just $ T.concat $ tail p
instance PrettyPrint RelPath where instance PrettyPrint RelPath where
prettyprint (Path up rest frag) = ups <> rest <> fragment prettyprint (Path up rest frag) = ups <> rest <> fragment
...@@ -59,14 +64,14 @@ instance PrettyPrint RelPath where ...@@ -59,14 +64,14 @@ instance PrettyPrint RelPath where
-- at the end of the prefix, i.e. it will never return paths -- at the end of the prefix, i.e. it will never return paths
-- that lie (naïvely) outside of the prefix. -- that lie (naïvely) outside of the prefix.
normalise :: FilePath -> RelPath -> FilePath 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 _) = 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 where dirs = splitPath prefix
normaliseWithFrag :: FilePath -> RelPath -> FilePath normaliseWithFrag :: FilePath -> RelPath -> FilePath
normaliseWithFrag prefix (Path i path frag) = 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 -- | does this path contain an old-style pattern for inter-repository
-- links as was used at rc3 in 2020? -- links as was used at rc3 in 2020?
...@@ -77,7 +82,5 @@ isOldStyle (Path _ text frag) = path =~ ("{<.+>*}" :: Text) ...@@ -77,7 +82,5 @@ isOldStyle (Path _ text frag) = path =~ ("{<.+>*}" :: Text)
_ -> text _ -> text
getExtension :: RelPath -> Text getExtension :: RelPath -> Text
getExtension (Path _ text _) = case length splitted of getExtension (Path _ text _) = maybe "" last (nonEmpty splitted)
0 -> ""
_ -> last splitted
where splitted = T.splitOn "." text where splitted = T.splitOn "." text
lib/Properties.hs
View file @ d3dcb5f4
This diff is collapsed.

Impressum - Datenschutzerklärung