From 9110064fe62f98dd3ecc5fb4c3915a843492b8fb Mon Sep 17 00:00:00 2001 From: stuebinm Date: Mon, 23 Oct 2023 23:18:34 +0200 Subject: a year went by This does many meta-things, but changes no functionality: - get rid of stack, and use just cabal with a stackage snapshot instead (why did I ever think stack was a good idea?) - update the stackage snapshot to something halfway recent - thus making builds work on nixpkgs-23.05 (current stable) - separating out packages into their own cabal files - use the GHC2021 set of extensions as default - very slight code changes to make things build again - update readme accordingly - stylish-haskell run --- .gitignore | 2 - .hlint.yaml | 1039 ------------------------------------ Readme.md | 49 +- cabal.project | 2 + default.nix | 51 +- flake.lock | 27 - flake.nix | 12 - lib/Badges.hs | 66 --- lib/CheckDir.hs | 284 ---------- lib/CheckMap.hs | 234 -------- lib/Dirgraph.hs | 84 --- lib/LayerData.hs | 42 -- lib/LintConfig.hs | 193 ------- lib/LintWriter.hs | 198 ------- lib/Paths.hs | 86 --- lib/Properties.hs | 753 -------------------------- lib/Types.hs | 130 ----- lib/Uris.hs | 106 ---- lib/Util.hs | 79 --- lib/WriteRepo.hs | 63 --- nix/sources.json | 38 -- nix/sources.nix | 174 ------ package.yaml | 98 ---- server/Handlers.hs | 2 - server/HtmlOrphans.hs | 6 +- server/Main.hs | 14 +- server/Server.hs | 31 +- server/Worker.hs | 12 +- server/default.nix | 26 + server/server.cabal | 55 ++ src/Main.hs | 111 ---- src/Version.hs | 17 - stack.yaml | 36 -- stack.yaml.lock | 33 -- static/Genos-VariableFont_wght.ttf | Bin 133948 -> 0 bytes static/Ubuntu-R.ttf | Bin 353824 -> 0 bytes static/style.css | 50 +- tiled/Data/Tiled.hs | 4 - tiled/default.nix | 13 + tiled/tiled.cabal | 24 + walint-cli/Main.hs | 108 ++++ walint-cli/Version.hs | 17 + walint-cli/default.nix | 18 + walint-cli/walint-cli.cabal | 27 + walint.cabal | 160 ------ walint/Badges.hs | 64 +++ walint/CheckDir.hs | 279 ++++++++++ walint/CheckMap.hs | 227 ++++++++ walint/Dirgraph.hs | 83 +++ walint/LayerData.hs | 42 ++ walint/LintConfig.hs | 187 +++++++ walint/LintWriter.hs | 192 +++++++ walint/Paths.hs | 86 +++ walint/Properties.hs | 748 ++++++++++++++++++++++++++ walint/Types.hs | 128 +++++ walint/Uris.hs | 103 ++++ walint/Util.hs | 79 +++ walint/WriteRepo.hs | 62 +++ walint/default.nix | 17 + walint/walint.cabal | 48 ++ 60 files changed, 2684 insertions(+), 4235 deletions(-) delete mode 100644 .hlint.yaml create mode 100644 cabal.project delete mode 100644 flake.lock delete mode 100644 flake.nix delete mode 100644 lib/Badges.hs delete mode 100644 lib/CheckDir.hs delete mode 100644 lib/CheckMap.hs delete mode 100644 lib/Dirgraph.hs delete mode 100644 lib/LayerData.hs delete mode 100644 lib/LintConfig.hs delete mode 100644 lib/LintWriter.hs delete mode 100644 lib/Paths.hs delete mode 100644 lib/Properties.hs delete mode 100644 lib/Types.hs delete mode 100644 lib/Uris.hs delete mode 100644 lib/Util.hs delete mode 100644 lib/WriteRepo.hs delete mode 100644 nix/sources.json delete mode 100644 nix/sources.nix delete mode 100644 package.yaml create mode 100644 server/default.nix create mode 100644 server/server.cabal delete mode 100644 src/Main.hs delete mode 100644 src/Version.hs delete mode 100644 stack.yaml delete mode 100644 stack.yaml.lock delete mode 100644 static/Genos-VariableFont_wght.ttf delete mode 100644 static/Ubuntu-R.ttf create mode 100644 tiled/default.nix create mode 100644 tiled/tiled.cabal create mode 100644 walint-cli/Main.hs create mode 100644 walint-cli/Version.hs create mode 100644 walint-cli/default.nix create mode 100644 walint-cli/walint-cli.cabal delete mode 100644 walint.cabal create mode 100644 walint/Badges.hs create mode 100644 walint/CheckDir.hs create mode 100644 walint/CheckMap.hs create mode 100644 walint/Dirgraph.hs create mode 100644 walint/LayerData.hs create mode 100644 walint/LintConfig.hs create mode 100644 walint/LintWriter.hs create mode 100644 walint/Paths.hs create mode 100644 walint/Properties.hs create mode 100644 walint/Types.hs create mode 100644 walint/Uris.hs create mode 100644 walint/Util.hs create mode 100644 walint/WriteRepo.hs create mode 100644 walint/default.nix create mode 100644 walint/walint.cabal diff --git a/.gitignore b/.gitignore index 7683061..305e3cb 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,2 @@ dist-newstyle/* -.stack-work -walint.cabal result* diff --git a/.hlint.yaml b/.hlint.yaml deleted file mode 100644 index 202635a..0000000 --- a/.hlint.yaml +++ /dev/null @@ -1,1039 +0,0 @@ -# This is a custom hlint config with rules that suggest -# using Universum functions whenever it has a suitable -# alternative. You may either copy-paste this config into -# your .hlint.yaml or run hlint twice: once with your -# default config, and the second time with this one. -# This config is *not* intended for Universum developers. - -############################################################################ -## Universum -############################################################################ - -# There's no 'head' in Universum -- ignore: {name: "Use head"} - -# We have 'whenJust' for this -- ignore: {name: "Use Foldable.forM_"} - -- warn: {lhs: Data.Text.pack, rhs: Universum.toText} -- warn: {lhs: Data.Text.unpack, rhs: Universum.toString} - -- warn: {lhs: Data.Text.Lazy.pack, rhs: Universum.toLText} -- warn: {lhs: Data.Text.Lazy.unpack, rhs: Universum.toString} -- warn: {lhs: Data.Text.Lazy.toStrict, rhs: Universum.toText} -- warn: {lhs: Data.Text.Lazy.fromStrict, rhs: Universum.toLText} - -- warn: {lhs: Data.Text.pack (show x), rhs: Universum.show x} -- warn: {lhs: Data.Text.Lazy.pack (show x), rhs: Universum.show x} - -- warn: {lhs: Control.Exception.evaluate, rhs: evaluateWHNF} -- warn: {lhs: Control.Exception.evaluate (force x), rhs: evaluateNF x} -- warn: {lhs: Control.Exception.evaluate (x `deepseq` ()), rhs: evaluateNF_ x} -- warn: {lhs: void (evaluateWHNF x), rhs: evaluateWHNF_ x} -- warn: {lhs: void (evaluateNF x), rhs: evaluateNF_ x} - -## Containers -- hint: {lhs: Data.HashMap.Lazy.keys, rhs: Universum.keys} -- hint: {lhs: Data.HashMap.Strict.keys, rhs: Universum.keys} -- hint: {lhs: Data.Map.Lazy.keys, rhs: Universum.keys} -- hint: {lhs: Data.Map.Strict.keys, rhs: Universum.keys} -- hint: {lhs: Data.IntMap.Lazy.keys, rhs: Universum.keys} -- hint: {lhs: Data.IntMap.Strict.keys, rhs: Universum.keys} - -- hint: {lhs: Data.HashMap.Lazy.elems, rhs: Universum.elems} -- hint: {lhs: Data.HashMap.Strict.elems, rhs: Universum.elems} -- hint: {lhs: Data.Map.Lazy.elems, rhs: Universum.elems} -- hint: {lhs: Data.Map.Strict.elems, rhs: Universum.elems} -- hint: {lhs: Data.IntMap.Lazy.elems, rhs: Universum.elems} -- hint: {lhs: Data.IntMap.Strict.elems, rhs: Universum.elems} - -- hint: {lhs: Data.HashMap.Lazy.toList, rhs: Universum.toPairs} -- hint: {lhs: Data.HashMap.Strict.toList, rhs: Universum.toPairs} -- hint: {lhs: Data.Map.Lazy.toList, rhs: Universum.toPairs} -- hint: {lhs: Data.Map.Lazy.assocs, rhs: Universum.toPairs} -- hint: {lhs: Data.Map.Strict.toList, rhs: Universum.toPairs} -- hint: {lhs: Data.Map.Strict.assocs, rhs: Universum.toPairs} -- hint: {lhs: Data.IntMap.Lazy.toList, rhs: Universum.toPairs} -- hint: {lhs: Data.IntMap.Lazy.assocs, rhs: Universum.toPairs} -- hint: {lhs: Data.IntMap.Strict.toList, rhs: Universum.toPairs} -- hint: {lhs: Data.IntMap.Strict.assocs, rhs: Universum.toPairs} - -- warn: { lhs: Data.Map.toAscList (Data.Map.fromList x) - , rhs: Universum.sortWith fst x - } -- warn: { lhs: Data.Map.toDescList (Data.Map.fromList x) - , rhs: Universum.sortWith (Down . fst) x - } - -- warn: {lhs: Data.Set.toList (Data.Set.fromList l), rhs: Universum.sortNub l} -- warn: {lhs: Data.Set.assocs (Data.Set.fromList l), rhs: Universum.sortNub l} -- warn: {lhs: Data.Set.toAscList (Data.Set.fromList l), rhs: Universum.sortNub l} - -- warn: {lhs: Data.HashSet.toList (Data.HashSet.fromList l), rhs: Universum.unstableNub} - -- hint: { lhs: nub, rhs: Universum.ordNub - , note: "'nub' is O(n^2), 'ordNub' is O(n log n)" } - -- warn: { lhs: sortBy (comparing f), rhs: Universum.sortWith f - , note: "If the function you are using for 'comparing' is slow, use 'sortOn' instead of 'sortWith', because 'sortOn' caches applications the function and 'sortWith' doesn't." } - -- warn: { lhs: sortOn fst, rhs: Universum.sortWith fst - , note: "'sortWith' will be faster here because it doesn't do caching" } -- warn: { lhs: sortOn snd, rhs: Universum.sortWith snd - , note: "'sortWith' will be faster here because it doesn't do caching" } -- warn: { lhs: sortOn (Down . fst), rhs: Universum.sortWith (Down . fst) - , note: "'sortWith' will be faster here because it doesn't do caching" } -- warn: { lhs: sortOn (Down . snd), rhs: Universum.sortWith (Down . snd) - , note: "'sortWith' will be faster here because it doesn't do caching" } - -- warn: {lhs: map fst &&& map snd, rhs: unzip} - -- warn: {lhs: f >>= guard, rhs: guardM} -- warn: {lhs: guard =<< f, rhs: guardM} - -- warn: {lhs: fmap concat (mapM f s), rhs: Universum.concatMapM f s} -- warn: {lhs: concat <$> mapM f s, rhs: Universum.concatMapM f s} - -- warn: {lhs: fmap concat (forM f s), rhs: Universum.concatForM s f} -- warn: {lhs: fmap concat (for f s), rhs: Universum.concatForM s f} -- warn: {lhs: concat <$> forM f s, rhs: Universum.concatForM s f} -- warn: {lhs: concat <$> for f s, rhs: Universum.concatForM s f} - -- hint: { lhs: fmap and (sequence s), rhs: Universum.andM s - , note: "Applying this hint would mean that some actions\n that were being executed previously would no longer be executed." } -- hint: { lhs: and <$> sequence s, rhs: Universum.andM s - , note: "Applying this hint would mean that some actions\n that were being executed previously would no longer be executed." } - -- hint: { lhs: fmap or (sequence s), rhs: Universum.orM s - , note: "Applying this hint would mean that some actions\n that were being executed previously would no longer be executed." } -- hint: { lhs: or <$> sequence s, rhs: Universum.orM s - , note: "Applying this hint would mean that some actions\n that were being executed previously would no longer be executed." } - -- hint: { lhs: fmap and (mapM f s), rhs: Universum.allM f s - , note: "Applying this hint would mean that some actions\n that were being executed previously would no longer be executed." } -- hint: { lhs: and <$> mapM f s, rhs: Universum.allM f s - , note: "Applying this hint would mean that some actions\n that were being executed previously would no longer be executed." } -- hint: { lhs: fmap or (mapM f s), rhs: Universum.anyM f s - , note: "Applying this hint would mean that some actions\n that were being executed previously would no longer be executed." } -- hint: { lhs: or <$> mapM f s, rhs: Universum.anyM f s - , note: "Applying this hint would mean that some actions\n that were being executed previously would no longer be executed." } - -- warn: {lhs: whenM (not <$> x), rhs: unlessM x} -- warn: {lhs: unlessM (not <$> x), rhs: whenM x} - -- warn: {lhs: either (const True) (const False), rhs: isLeft} -- warn: {lhs: either (const False) (const True), rhs: isRight} - -- warn: {lhs: either id (const a), rhs: fromLeft a} -- warn: {lhs: either (const b) id, rhs: fromRight b} - -- warn: {lhs: either Just (const Nothing), rhs: leftToMaybe} -- warn: {lhs: either (const Nothing) Just, rhs: rightToMaybe} -- warn: {lhs: maybe (Left l) Right, rhs: maybeToRight} -- warn: {lhs: maybe (Right r) Left, rhs: maybeToLeft} - -- warn: {lhs: fromMaybe mempty, rhs: maybeToMonoid} -- warn: {lhs: "m ?: mempty", rhs: maybeToMonoid m} - - -# Probably will be reduced when function equality is done: -# https://github.com/ndmitchell/hlint/issues/434 -- warn: {lhs: (case m of Just x -> f x; Nothing -> pure () ), rhs: Universum.whenJust m f} -- warn: {lhs: (case m of Just x -> f x; Nothing -> return ()), rhs: Universum.whenJust m f} -- warn: {lhs: (case m of Just x -> f x; Nothing -> pass ), rhs: Universum.whenJust m f} -- warn: {lhs: (case m of Nothing -> pure () ; Just x -> f x), rhs: Universum.whenJust m f} -- warn: {lhs: (case m of Nothing -> return (); Just x -> f x), rhs: Universum.whenJust m f} -- warn: {lhs: (case m of Nothing -> pass ; Just x -> f x), rhs: Universum.whenJust m f} -- warn: {lhs: (maybe (pure ()) f m), rhs: Universum.whenJust m f} -- warn: {lhs: (maybe (return ()) f m), rhs: Universum.whenJust m f} -- warn: {lhs: (maybe pass f m), rhs: Universum.whenJust m f} - -- warn: {lhs: (m >>= \case Just x -> f x; Nothing -> pure () ), rhs: Universum.whenJustM m f} -- warn: {lhs: (m >>= \case Just x -> f x; Nothing -> return ()), rhs: Universum.whenJustM m f} -- warn: {lhs: (m >>= \case Just x -> f x; Nothing -> pass ), rhs: Universum.whenJustM m f} -- warn: {lhs: (m >>= \case Nothing -> pure () ; Just x -> f x), rhs: Universum.whenJustM m f} -- warn: {lhs: (m >>= \case Nothing -> return (); Just x -> f x), rhs: Universum.whenJustM m f} -- warn: {lhs: (m >>= \case Nothing -> pass ; Just x -> f x), rhs: Universum.whenJustM m f} -- warn: {lhs: (maybe (pure ()) f =<< m), rhs: Universum.whenJustM m f} -- warn: {lhs: (maybe (return ()) f =<< m), rhs: Universum.whenJustM m f} -- warn: {lhs: (maybe pass f =<< m), rhs: Universum.whenJustM m f} -- warn: {lhs: (m >>= maybe (pure ()) f), rhs: Universum.whenJustM m f} -- warn: {lhs: (m >>= maybe (return ()) f), rhs: Universum.whenJustM m f} -- warn: {lhs: (m >>= maybe pass f), rhs: Universum.whenJustM m f} - -- warn: {lhs: (case m of Just _ -> pure () ; Nothing -> x), rhs: Universum.whenNothing_ m x} -- warn: {lhs: (case m of Just _ -> return (); Nothing -> x), rhs: Universum.whenNothing_ m x} -- warn: {lhs: (case m of Just _ -> pass ; Nothing -> x), rhs: Universum.whenNothing_ m x} -- warn: {lhs: (case m of Nothing -> x; Just _ -> pure () ), rhs: Universum.whenNothing_ m x} -- warn: {lhs: (case m of Nothing -> x; Just _ -> return ()), rhs: Universum.whenNothing_ m x} -- warn: {lhs: (case m of Nothing -> x; Just _ -> pass ), rhs: Universum.whenNothing_ m x} -- warn: {lhs: (maybe x (\_ -> pure () ) m), rhs: Universum.whenNothing_ m x} -- warn: {lhs: (maybe x (\_ -> return () ) m), rhs: Universum.whenNothing_ m x} -- warn: {lhs: (maybe x (\_ -> pass ) m), rhs: Universum.whenNothing_ m x} -- warn: {lhs: (maybe x (const (pure () )) m), rhs: Universum.whenNothing_ m x} -- warn: {lhs: (maybe x (const (return ())) m), rhs: Universum.whenNothing_ m x} -- warn: {lhs: (maybe x (const (pass )) m), rhs: Universum.whenNothing_ m x} - -- warn: {lhs: (m >>= \case Just _ -> pure () ; Nothing -> x), rhs: Universum.whenNothingM_ m x} -- warn: {lhs: (m >>= \case Just _ -> return (); Nothing -> x), rhs: Universum.whenNothingM_ m x} -- warn: {lhs: (m >>= \case Just _ -> pass ; Nothing -> x), rhs: Universum.whenNothingM_ m x} -- warn: {lhs: (m >>= \case Nothing -> x; Just _ -> pure () ), rhs: Universum.whenNothingM_ m x} -- warn: {lhs: (m >>= \case Nothing -> x; Just _ -> return ()), rhs: Universum.whenNothingM_ m x} -- warn: {lhs: (m >>= \case Nothing -> x; Just _ -> pass ), rhs: Universum.whenNothingM_ m x} -- warn: {lhs: (maybe x (\_ -> pure () ) =<< m), rhs: Universum.whenNothingM_ m x} -- warn: {lhs: (maybe x (\_ -> return () ) =<< m), rhs: Universum.whenNothingM_ m x} -- warn: {lhs: (maybe x (\_ -> pass ) =<< m), rhs: Universum.whenNothingM_ m x} -- warn: {lhs: (maybe x (const (pure () )) =<< m), rhs: Universum.whenNothingM_ m x} -- warn: {lhs: (maybe x (const (return ())) =<< m), rhs: Universum.whenNothingM_ m x} -- warn: {lhs: (maybe x (const (pass )) =<< m), rhs: Universum.whenNothingM_ m x} -- warn: {lhs: (m >>= maybe x (\_ -> pure ()) ), rhs: Universum.whenNothingM_ m x} -- warn: {lhs: (m >>= maybe x (\_ -> return ()) ), rhs: Universum.whenNothingM_ m x} -- warn: {lhs: (m >>= maybe x (\_ -> pass) ), rhs: Universum.whenNothingM_ m x} -- warn: {lhs: (m >>= maybe x (const (pure ()) )), rhs: Universum.whenNothingM_ m x} -- warn: {lhs: (m >>= maybe x (const (return ()))), rhs: Universum.whenNothingM_ m x} -- warn: {lhs: (m >>= maybe x (const (pass) )), rhs: Universum.whenNothingM_ m x} - -- warn: {lhs: (case m of Left x -> f x; Right _ -> pure () ), rhs: Universum.whenLeft m f} -- warn: {lhs: (case m of Left x -> f x; Right _ -> return ()), rhs: Universum.whenLeft m f} -- warn: {lhs: (case m of Left x -> f x; Right _ -> pass ), rhs: Universum.whenLeft m f} -- warn: {lhs: (case m of Right _ -> pure () ; Left x -> f x), rhs: Universum.whenLeft m f} -- warn: {lhs: (case m of Right _ -> return (); Left x -> f x), rhs: Universum.whenLeft m f} -- warn: {lhs: (case m of Right _ -> pass ; Left x -> f x), rhs: Universum.whenLeft m f} -- warn: {lhs: (either f (\_ -> pure () ) m), rhs: Universum.whenLeft m f} -- warn: {lhs: (either f (\_ -> return () ) m), rhs: Universum.whenLeft m f} -- warn: {lhs: (either f (\_ -> pass ) m), rhs: Universum.whenLeft m f} -- warn: {lhs: (either f (const (pure () )) m), rhs: Universum.whenLeft m f} -- warn: {lhs: (either f (const (return ())) m), rhs: Universum.whenLeft m f} -- warn: {lhs: (either f (const (pass )) m), rhs: Universum.whenLeft m f} - -- warn: {lhs: (m >>= \case Left x -> f x; Right _ -> pure () ), rhs: Universum.whenLeftM m f} -- warn: {lhs: (m >>= \case Left x -> f x; Right _ -> return ()), rhs: Universum.whenLeftM m f} -- warn: {lhs: (m >>= \case Left x -> f x; Right _ -> pass ), rhs: Universum.whenLeftM m f} -- warn: {lhs: (m >>= \case Right _ -> pure () ; Left x -> f x), rhs: Universum.whenLeftM m f} -- warn: {lhs: (m >>= \case Right _ -> return (); Left x -> f x), rhs: Universum.whenLeftM m f} -- warn: {lhs: (m >>= \case Right _ -> pass ; Left x -> f x), rhs: Universum.whenLeftM m f} -- warn: {lhs: (either f (\_ -> pure () ) =<< m), rhs: Universum.whenLeftM m f} -- warn: {lhs: (either f (\_ -> return () ) =<< m), rhs: Universum.whenLeftM m f} -- warn: {lhs: (either f (\_ -> pass ) =<< m), rhs: Universum.whenLeftM m f} -- warn: {lhs: (either f (const (pure () )) =<< m), rhs: Universum.whenLeftM m f} -- warn: {lhs: (either f (const (return ())) =<< m), rhs: Universum.whenLeftM m f} -- warn: {lhs: (either f (const (pass )) =<< m), rhs: Universum.whenLeftM m f} -- warn: {lhs: (m >>= either f (\_ -> pure ()) ), rhs: Universum.whenLeftM m f} -- warn: {lhs: (m >>= either f (\_ -> return ()) ), rhs: Universum.whenLeftM m f} -- warn: {lhs: (m >>= either f (\_ -> pass) ), rhs: Universum.whenLeftM m f} -- warn: {lhs: (m >>= either f (const (pure ()) )), rhs: Universum.whenLeftM m f} -- warn: {lhs: (m >>= either f (const (return ()))), rhs: Universum.whenLeftM m f} -- warn: {lhs: (m >>= either f (const (pass) )), rhs: Universum.whenLeftM m f} - -- warn: {lhs: (case m of Right x -> f x; Left _ -> pure () ), rhs: Universum.whenRight m f} -- warn: {lhs: (case m of Right x -> f x; Left _ -> return ()), rhs: Universum.whenRight m f} -- warn: {lhs: (case m of Right x -> f x; Left _ -> pass ), rhs: Universum.whenRight m f} -- warn: {lhs: (case m of Left _ -> pure () ; Right x -> f x), rhs: Universum.whenRight m f} -- warn: {lhs: (case m of Left _ -> return (); Right x -> f x), rhs: Universum.whenRight m f} -- warn: {lhs: (case m of Left _ -> pass ; Right x -> f x), rhs: Universum.whenRight m f} -- warn: {lhs: (either (\_ -> pure () ) f m), rhs: Universum.whenRight m f} -- warn: {lhs: (either (\_ -> return () ) f m), rhs: Universum.whenRight m f} -- warn: {lhs: (either (\_ -> pass ) f m), rhs: Universum.whenRight m f} -- warn: {lhs: (either (const (pure () )) f m), rhs: Universum.whenRight m f} -- warn: {lhs: (either (const (return ())) f m), rhs: Universum.whenRight m f} -- warn: {lhs: (either (const (pass )) f m), rhs: Universum.whenRight m f} - -- warn: {lhs: (m >>= \case Right x -> f x; Left _ -> pure () ), rhs: Universum.whenRightM m f} -- warn: {lhs: (m >>= \case Right x -> f x; Left _ -> return ()), rhs: Universum.whenRightM m f} -- warn: {lhs: (m >>= \case Right x -> f x; Left _ -> pass ), rhs: Universum.whenRightM m f} -- warn: {lhs: (m >>= \case Left _ -> pure () ; Right x -> f x), rhs: Universum.whenRightM m f} -- warn: {lhs: (m >>= \case Left _ -> return (); Right x -> f x), rhs: Universum.whenRightM m f} -- warn: {lhs: (m >>= \case Left _ -> pass ; Right x -> f x), rhs: Universum.whenRightM m f} -- warn: {lhs: (either (\_ -> pure () ) f =<< m), rhs: Universum.whenRightM m f} -- warn: {lhs: (either (\_ -> return () ) f =<< m), rhs: Universum.whenRightM m f} -- warn: {lhs: (either (\_ -> pass ) f =<< m), rhs: Universum.whenRightM m f} -- warn: {lhs: (either (const (pure () )) f =<< m), rhs: Universum.whenRightM m f} -- warn: {lhs: (either (const (return ())) f =<< m), rhs: Universum.whenRightM m f} -- warn: {lhs: (either (const (pass )) f =<< m), rhs: Universum.whenRightM m f} -- warn: {lhs: (m >>= either (\_ -> pure ()) f), rhs: Universum.whenRightM m f} -- warn: {lhs: (m >>= either (\_ -> return ()) f), rhs: Universum.whenRightM m f} -- warn: {lhs: (m >>= either (\_ -> pass) f), rhs: Universum.whenRightM m f} -- warn: {lhs: (m >>= either (const (pure ()) ) f), rhs: Universum.whenRightM m f} -- warn: {lhs: (m >>= either (const (return ())) f), rhs: Universum.whenRightM m f} -- warn: {lhs: (m >>= either (const (pass) ) f), rhs: Universum.whenRightM m f} - -- warn: {lhs: "(case m of [] -> return (); (x:xs) -> f (x :| xs))", rhs: Universum.whenNotNull m f} -- warn: {lhs: "(case m of [] -> pure () ; (x:xs) -> f (x :| xs))", rhs: Universum.whenNotNull m f} -- warn: {lhs: "(case m of [] -> pass ; (x:xs) -> f (x :| xs))", rhs: Universum.whenNotNull m f} -- warn: {lhs: "(case m of (x:xs) -> f (x :| xs); [] -> return ())", rhs: Universum.whenNotNull m f} -- warn: {lhs: "(case m of (x:xs) -> f (x :| xs); [] -> pure () )", rhs: Universum.whenNotNull m f} -- warn: {lhs: "(case m of (x:xs) -> f (x :| xs); [] -> pass )", rhs: Universum.whenNotNull m f} -- warn: {lhs: "(m >>= \\case [] -> pass ; (x:xs) -> f (x :| xs))", rhs: Universum.whenNotNullM m f} -- warn: {lhs: "(m >>= \\case [] -> pure () ; (x:xs) -> f (x :| xs))", rhs: Universum.whenNotNullM m f} -- warn: {lhs: "(m >>= \\case [] -> return (); (x:xs) -> f (x :| xs))", rhs: Universum.whenNotNullM m f} -- warn: {lhs: "(m >>= \\case (x:xs) -> f (x :| xs); [] -> pass )", rhs: Universum.whenNotNullM m f} -- warn: {lhs: "(m >>= \\case (x:xs) -> f (x :| xs); [] -> pure () )", rhs: Universum.whenNotNullM m f} -- warn: {lhs: "(m >>= \\case (x:xs) -> f (x :| xs); [] -> return ())", rhs: Universum.whenNotNullM m f} - -- warn: {lhs: mapMaybe leftToMaybe, rhs: lefts} -- warn: {lhs: mapMaybe rightToMaybe, rhs: rights} - -############################################################################ -## Reexports -############################################################################ - -## Applicative -- warn: { name: "Use 'Alternative' from Universum" - , lhs: Control.Applicative.Alternative, rhs: Universum.Alternative } -- warn: { name: "Use 'empty' from Universum" - , lhs: Control.Applicative.empty, rhs: Universum.empty } -- warn: { name: "Use '(<|>)' from Universum" - , lhs: Control.Applicative.(<|>), rhs: Universum.(<|>) } -- warn: { name: "Use 'some' from Universum" - , lhs: Control.Applicative.some, rhs: Universum.some } -- warn: { name: "Use 'many' from Universum" - , lhs: Control.Applicative.many, rhs: Universum.many } -- warn: { name: "Use 'Const' from Universum" - , lhs: Control.Applicative.Const, rhs: Universum.Const } -- warn: { name: "Use 'getConst' from Universum" - , lhs: Control.Applicative.getConst, rhs: Universum.getConst } -- warn: { name: "Use 'ZipList' from Universum" - , lhs: Control.Applicative.ZipList, rhs: Universum.ZipList } -- warn: { name: "Use 'getZipList' from Universum" - , lhs: Control.Applicative.getZipList, rhs: Universum.getZipList } -- warn: { name: "Use 'liftA2' from Universum" - , lhs: Control.Applicative.liftA2, rhs: Universum.liftA2 } -- warn: { name: "Use 'liftA3' from Universum" - , lhs: Control.Applicative.liftA3, rhs: Universum.liftA3 } -- warn: { name: "Use 'optional' from Universum" - , lhs: Control.Applicative.optional, rhs: Universum.optional } -- warn: { name: "Use '(<**>)' from Universum" - , lhs: Control.Applicative.(<**>), rhs: Universum.(<**>) } - -## Base -- warn: { name: "Use 'xor' from Universum" - , lhs: Data.Bits.xor, rhs: Universum.xor } - -- warn: { name: "Use 'chr' from Universum" - , lhs: Data.Char.chr, rhs: Universum.chr } - -- warn: { name: "Use 'Int16' from Universum" - , lhs: Data.Int.Int16, rhs: Universum.Int16 } -- warn: { name: "Use 'Int32' from Universum" - , lhs: Data.Int.Int32, rhs: Universum.Int32 } -- warn: { name: "Use 'Int64' from Universum" - , lhs: Data.Int.Int64, rhs: Universum.Int64 } -- warn: { name: "Use 'Int8' from Universum" - , lhs: Data.Int.Int8, rhs: Universum.Int8 } - -- warn: { name: "Use 'Word16' from Universum" - , lhs: Data.Word.Word16, rhs: Universum.Word16 } -- warn: { name: "Use 'Word32' from Universum" - , lhs: Data.Word.Word32, rhs: Universum.Word32 } -- warn: { name: "Use 'Word64' from Universum" - , lhs: Data.Word.Word64, rhs: Universum.Word64 } -- warn: { name: "Use 'Word8' from Universum" - , lhs: Data.Word.Word8, rhs: Universum.Word8 } -- warn: { name: "Use 'byteSwap16' from Universum" - , lhs: Data.Word.byteSwap16, rhs: Universum.byteSwap16 } -- warn: { name: "Use 'byteSwap32' from Universum" - , lhs: Data.Word.byteSwap32, rhs: Universum.byteSwap32 } -- warn: { name: "Use 'byteSwap64' from Universum" - , lhs: Data.Word.byteSwap64, rhs: Universum.byteSwap64 } - -- warn: { name: "Use 'Natural' from Universum" - , lhs: Numeric.Natural.Natural, rhs: Universum.Natural } - -- warn: { name: "Use 'Handle' from Universum" - , lhs: System.IO.Handle, rhs: Universum.Handle } -- warn: { name: "Use 'IOMode' from Universum" - , lhs: System.IO.IOMode, rhs: Universum.IOMode } -- warn: { name: "Use 'ReadMode' from Universum" - , lhs: System.IO.ReadMode, rhs: Universum.ReadMode } -- warn: { name: "Use 'WriteMode' from Universum" - , lhs: System.IO.WriteMode, rhs: Universum.WriteMode } -- warn: { name: "Use 'AppendMode' from Universum" - , lhs: System.IO.AppendMode, rhs: Universum.AppendMode } -- warn: { name: "Use 'ReadWriteMode' from Universum" - , lhs: System.IO.ReadWriteMode, rhs: Universum.ReadWriteMode } -- warn: { name: "Use 'stderr' from Universum" - , lhs: System.IO.stderr, rhs: Universum.stderr } -- warn: { name: "Use 'stdin' from Universum" - , lhs: System.IO.stdin, rhs: Universum.stdin } -- warn: { name: "Use 'stdout' from Universum" - , lhs: System.IO.stdout, rhs: Universum.stdout } -- warn: { name: "Use 'withFile' from Universum" - , lhs: System.IO.withFile, rhs: Universum.withFile } - -- warn: { name: "Use 'foldlM' from Universum" - , lhs: Data.Foldable.foldlM, rhs: Universum.foldlM } -- warn: { name: "Use 'foldrM' from Universum" - , lhs: Data.Foldable.foldrM, rhs: Universum.foldrM } -- warn: { name: "Use 'maximumBy' from Universum" - , lhs: Data.Foldable.maximumBy, rhs: Universum.maximumBy } -- warn: { name: "Use 'minimumBy' from Universum" - , lhs: Data.Foldable.minimumBy, rhs: Universum.minimumBy } - -- warn: { name: "Use 'Down' from Universum" - , lhs: Data.Ord.Down, rhs: Universum.Down } -- warn: { name: "Use 'comparing' from Universum" - , lhs: Data.Ord.comparing, rhs: Universum.comparing } - -- warn: { name: "Use 'fmapDefault' from Universum" - , lhs: Data.Traversable.fmapDefault, rhs: Universum.fmapDefault } -- warn: { name: "Use 'foldMapDefault' from Universum" - , lhs: Data.Traversable.foldMapDefault, rhs: Universum.foldMapDefault } -- warn: { name: "Use 'forM' from Universum" - , lhs: Data.Traversable.forM, rhs: Universum.forM } -- warn: { name: "Use 'mapAccumL' from Universum" - , lhs: Data.Traversable.mapAccumL, rhs: Universum.mapAccumL } -- warn: { name: "Use 'mapAccumR' from Universum" - , lhs: Data.Traversable.mapAccumR, rhs: Universum.mapAccumR } - -- warn: { name: "Use 'Proxy' from Universum" - , lhs: Data.Proxy.Proxy, rhs: Universum.Proxy } - -- warn: { name: "Use 'Typeable' from Universum" - , lhs: Data.Typeable.Typeable, rhs: Universum.Typeable } - -- warn: { name: "Use 'Void' from Universum" - , lhs: Data.Void.Void, rhs: Universum.Void } -- warn: { name: "Use 'absurd' from Universum" - , lhs: Data.Void.absurd, rhs: Universum.absurd } -- warn: { name: "Use 'vacuous' from Universum" - , lhs: Data.Void.vacuous, rhs: Universum.vacuous } - -- warn: { name: "Use 'maxInt' from Universum" - , lhs: Data.Base.maxInt, rhs: Universum.maxInt } -- warn: { name: "Use 'minInt' from Universum" - , lhs: Data.Base.minInt, rhs: Universum.minInt } -- warn: { name: "Use 'ord' from Universum" - , lhs: Data.Base.ord, rhs: Universum.ord } - -- warn: { name: "Use 'boundedEnumFrom' from Universum" - , lhs: GHC.Enum.boundedEnumFrom, rhs: Universum.boundedEnumFrom } -- warn: { name: "Use 'boundedEnumFromThen' from Universum" - , lhs: GHC.Enum.boundedEnumFromThen, rhs: Universum.boundedEnumFromThen } - -- warn: { name: "Use 'Constraint' from Universum" - , lhs: GHC.Exts.Constraint, rhs: Universum.Constraint } -- warn: { name: "Use 'FunPtr' from Universum" - , lhs: GHC.Exts.FunPtr, rhs: Universum.FunPtr } -- warn: { name: "Use 'Ptr' from Universum" - , lhs: GHC.Exts.Ptr, rhs: Universum.Ptr } - -- warn: { name: "Use 'Generic' from Universum" - , lhs: GHC.Generics.Generic, rhs: Universum.Generic } - -- warn: { name: "Use 'Ratio' from Universum" - , lhs: GHC.Real.Ratio, rhs: Universum.Ratio } -- warn: { name: "Use 'Rational' from Universum" - , lhs: GHC.Real.Rational, rhs: Universum.Rational } - -- warn: { name: "Use 'CmpNat' from Universum" - , lhs: GHC.TypeNats.CmpNat, rhs: Universum.CmpNat } -- warn: { name: "Use 'KnownNat' from Universum" - , lhs: GHC.TypeNats.KnownNat, rhs: Universum.KnownNat } -- warn: { name: "Use 'Nat' from Universum" - , lhs: GHC.TypeNats.Nat, rhs: Universum.Nat } -- warn: { name: "Use 'SomeNat' from Universum" - , lhs: GHC.TypeNats.SomeNat, rhs: Universum.SomeNat } -- warn: { name: "Use 'natVal' from Universum" - , lhs: GHC.TypeNats.natVal, rhs: Universum.natVal } -- warn: { name: "Use 'someNatVal' from Universum" - , lhs: GHC.TypeNats.someNatVal, rhs: Universum.someNatVal } - -- warn: { name: "Use 'CmpNat' from Universum" - , lhs: GHC.TypeLits.CmpNat, rhs: Universum.CmpNat } -- warn: { name: "Use 'KnownNat' from Universum" - , lhs: GHC.TypeLits.KnownNat, rhs: Universum.KnownNat } -- warn: { name: "Use 'Nat' from Universum" - , lhs: GHC.TypeLits.Nat, rhs: Universum.Nat } -- warn: { name: "Use 'SomeNat' from Universum" - , lhs: GHC.TypeLits.SomeNat, rhs: Universum.SomeNat } -- warn: { name: "Use 'natVal' from Universum" - , lhs: GHC.TypeLits.natVal, rhs: Universum.natVal } -- warn: { name: "Use 'someNatVal' from Universum" - , lhs: GHC.TypeLits.someNatVal, rhs: Universum.someNatVal } - -- warn: { name: "Use 'Coercible' from Universum" - , lhs: GHC.Types.Coercible, rhs: Universum.Coercible } - -- warn: { name: "Use 'getStackTrace' from Universum" - , lhs: GHC.ExecutionStack.getStackTrace, rhs: Universum.getStackTrace } -- warn: { name: "Use 'showStackTrace' from Universum" - , lhs: GHC.ExecutionStack.showStackTrace, rhs: Universum.showStackTrace } - -- warn: { name: "Use 'IsLabel' from Universum" - , lhs: GHC.OverloadedLabels.IsLabel, rhs: Universum.IsLabel } -- warn: { name: "Use 'fromLabel' from Universum" - , lhs: GHC.OverloadedLabels.fromLabel, rhs: Universum.fromLabel } - -- warn: { name: "Use 'CallStack' from Universum" - , lhs: GHC.Stack.CallStack, rhs: Universum.CallStack } -- warn: { name: "Use 'HasCallStack' from Universum" - , lhs: GHC.Stack.HasCallStack, rhs: Universum.HasCallStack } -- warn: { name: "Use 'callStack' from Universum" - , lhs: GHC.Stack.callStack, rhs: Universum.callStack } -- warn: { name: "Use 'currentCallStack' from Universum" - , lhs: GHC.Stack.currentCallStack, rhs: Universum.currentCallStack } -- warn: { name: "Use 'getCallStack' from Universum" - , lhs: GHC.Stack.getCallStack, rhs: Universum.getCallStack } -- warn: { name: "Use 'prettyCallStack' from Universum" - , lhs: GHC.Stack.prettyCallStack, rhs: Universum.prettyCallStack } -- warn: { name: "Use 'prettySrcLoc' from Universum" - , lhs: GHC.Stack.prettySrcLoc, rhs: Universum.prettySrcLoc } -- warn: { name: "Use 'withFrozenCallStack' from Universum" - , lhs: GHC.Stack.withFrozenCallStack, rhs: Universum.withFrozenCallStack } - -- warn: { name: "Use 'Type' from Universum" - , lhs: Data.Kind.Type, rhs: Universum.Type } - -## Bool - -- warn: { name: "Use 'guard' from Universum" - , lhs: Control.Monad.guard, rhs: Universum.guard } -- warn: { name: "Use 'unless' from Universum" - , lhs: Control.Monad.unless, rhs: Universum.unless } -- warn: { name: "Use 'when' from Universum" - , lhs: Control.Monad.when, rhs: Universum.when } -- warn: { name: "Use 'bool' from Universum" - , lhs: Data.Bool.bool, rhs: Universum.bool } - -## Container -- warn: { name: "Use 'Hashable' from Universum" - , lhs: Data.Hashable.Hashable, rhs: Universum.Hashable } -- warn: { name: "Use 'hashWithSalt' from Universum" - , lhs: Data.Hashable.hashWithSalt, rhs: Universum.hashWithSalt } -- warn: { name: "Use 'HashMap' from Universum" - , lhs: Data.HashMap.Strict.HashMap, rhs: Universum.HashMap } -- warn: { name: "Use 'HashSet' from Universum" - , lhs: Data.HashSet.HashSet, rhs: Universum.HashSet } -- warn: { name: "Use 'IntMap' from Universum" - , lhs: Data.IntMap.Strict.IntMap, rhs: Universum.IntMap } -- warn: { name: "Use 'IntSet' from Universum" - , lhs: Data.IntSet.IntSet, rhs: Universum.IntSet } -- warn: { name: "Use 'Map' from Universum" - , lhs: Data.Map.Strict.Map, rhs: Universum.Map } -- warn: { name: "Use 'Sequence' from Universum" - , lhs: Data.Sequence.Sequence, rhs: Universum.Sequence } -- warn: { name: "Use 'Set' from Universum" - , lhs: Data.Set.Set, rhs: Universum.Set } -- warn: { name: "Use 'swap' from Universum" - , lhs: Data.Tuple.swap, rhs: Universum.swap } -- warn: { name: "Use 'Vector' from Universum" - , lhs: Data.Vector.Vector, rhs: Universum.Vector } - -## Deepseq -- warn: { name: "Use 'NFData' from Universum" - , lhs: Control.DeepSeq.NFData, rhs: Universum.NFData } -- warn: { name: "Use 'rnf' from Universum" - , lhs: Control.DeepSeq.rnf, rhs: Universum.rnf } -- warn: { name: "Use 'deepseq' from Universum" - , lhs: Control.DeepSeq.deepseq, rhs: Universum.deepseq } -- warn: { name: "Use 'force' from Universum" - , lhs: Control.DeepSeq.force, rhs: Universum.force } -- warn: { name: "Use '($!!)' from Universum" - , lhs: "Control.DeepSeq.($!!)", rhs: "Universum.($!!)" } - -## Exception -- warn: { name: "Use 'Exception' from Universum" - , lhs: Control.Exception.Exception, rhs: Universum.Exception } -- warn: { name: "Use 'toException' from Universum" - , lhs: Control.Exception.toException, rhs: Universum.toException } -- warn: { name: "Use 'fromException' from Universum" - , lhs: Control.Exception.fromException, rhs: Universum.fromException } - -- warn: { name: "Use 'Exception' from Universum" - , lhs: Control.Exception.Safe.Exception, rhs: Universum.Exception } -- warn: { name: "Use 'toException' from Universum" - , lhs: Control.Exception.Safe.toException, rhs: Universum.toException } -- warn: { name: "Use 'fromException' from Universum" - , lhs: Control.Exception.Safe.fromException, rhs: Universum.fromException } -- warn: { name: "Use 'displayException' from Universum" - , lhs: Control.Exception.Safe.displayException, rhs: Universum.displayException } -- warn: { name: "Use 'MonadCatch' from Universum" - , lhs: Control.Exception.Safe.MonadCatch, rhs: Universum.MonadCatch } -- warn: { name: "Use 'MonadMask' from Universum" - , lhs: Control.Exception.Safe.MonadMask, rhs: Universum.MonadMask } -- warn: { name: "Use 'mask' from Universum" - , lhs: Control.Exception.Safe.mask, rhs: Universum.mask } -- warn: { name: "Use 'uninterruptibleMask' from Universum" - , lhs: Control.Exception.Safe.uninterruptibleMask, rhs: Universum.uninterruptibleMask } -- warn: { name: "Use 'MonadThrow' from Universum" - , lhs: Control.Exception.Safe.MonadThrow, rhs: Universum.MonadThrow } -- warn: { name: "Use 'SomeException' from Universum" - , lhs: Control.Exception.Safe.SomeException, rhs: Universum.SomeException } -- warn: { name: "Use 'bracket' from Universum" - , lhs: Control.Exception.Safe.bracket, rhs: Universum.bracket } -- warn: { name: "Use 'bracketOnError' from Universum" - , lhs: Control.Exception.Safe.bracketOnError, rhs: Universum.bracketOnError } -- warn: { name: "Use 'bracket_' from Universum" - , lhs: Control.Exception.Safe.bracket_, rhs: Universum.bracket_ } -- warn: { name: "Use 'catch' from Universum" - , lhs: Control.Exception.Safe.catch, rhs: Universum.catch } -- warn: { name: "Use 'catchAny' from Universum" - , lhs: Control.Exception.Safe.catchAny, rhs: Universum.catchAny } -- warn: { name: "Use 'finally' from Universum" - , lhs: Control.Exception.Safe.finally, rhs: Universum.finally } -- warn: { name: "Use 'handleAny' from Universum" - , lhs: Control.Exception.Safe.handleAny, rhs: Universum.handleAny } -- warn: { name: "Use 'onException' from Universum" - , lhs: Control.Exception.Safe.onException, rhs: Universum.onException } -- warn: { name: "Use 'throwM' from Universum" - , lhs: Control.Exception.Safe.throwM, rhs: Universum.throwM } -- warn: { name: "Use 'try' from Universum" - , lhs: Control.Exception.Safe.try, rhs: Universum.try } -- warn: { name: "Use 'tryAny' from Universum" - , lhs: Control.Exception.Safe.tryAny, rhs: Universum.tryAny } - -## Function -- warn: { name: "Use 'fix' from Universum" - , lhs: Data.Function.fix, rhs: Universum.fix } -- warn: { name: "Use 'on' from Universum" - , lhs: Data.Function.on, rhs: Universum.on } - -## Functor -- warn: { name: "Use '(&&&)' from Universum" - , lhs: Control.Arrow.(&&&), rhs: Universum.(&&&) } -- warn: { name: "Use 'Bifunctor' from Universum" - , lhs: Data.Bifunctor.Bifunctor, rhs: Universum.Bifunctor } -- warn: { name: "Use 'bimap' from Universum" - , lhs: Data.Bifunctor.bimap, rhs: Universum.bimap } -- warn: { name: "Use 'first' from Universum" - , lhs: Data.Bifunctor.first, rhs: Universum.first } -- warn: { name: "Use 'second' from Universum" - , lhs: Data.Bifunctor.second, rhs: Universum.second } -- warn: { name: "Use 'void' from Universum" - , lhs: Data.Functor.void, rhs: Universum.void } -- warn: { name: "Use '($>)' from Universum" - , lhs: Data.Functor.($>), rhs: Universum.($>) } -- warn: { name: "Use 'Compose' from Universum" - , lhs: Data.Functor.Compose.Compose, rhs: Universum.Compose } -- warn: { name: "Use 'getCompose' from Universum" - , lhs: Data.Functor.Compose.getCompose, rhs: Universum.getCompose } -- warn: { name: "Use 'Identity' from Universum" - , lhs: Data.Functor.Identity.Identity, rhs: Universum.Identity } -- warn: { name: "Use 'runIdentity' from Universum" - , lhs: Data.Functor.Identity.runIdentity, rhs: Universum.runIdentity } - -## List -- warn: { name: "Use 'genericDrop' from Universum" - , lhs: Data.List.genericDrop, rhs: Universum.genericDrop } -- warn: { name: "Use 'genericLength' from Universum" - , lhs: Data.List.genericLength, rhs: Universum.genericLength } -- warn: { name: "Use 'genericReplicate' from Universum" - , lhs: Data.List.genericReplicate, rhs: Universum.genericReplicate } -- warn: { name: "Use 'genericSplitAt' from Universum" - , lhs: Data.List.genericSplitAt, rhs: Universum.genericSplitAt } -- warn: { name: "Use 'genericTake' from Universum" - , lhs: Data.List.genericTake, rhs: Universum.genericTake } -- warn: { name: "Use 'group' from Universum" - , lhs: Data.List.group, rhs: Universum.group } -- warn: { name: "Use 'inits' from Universum" - , lhs: Data.List.inits, rhs: Universum.inits } -- warn: { name: "Use 'intercalate' from Universum" - , lhs: Data.List.intercalate, rhs: Universum.intercalate } -- warn: { name: "Use 'intersperse' from Universum" - , lhs: Data.List.intersperse, rhs: Universum.intersperse } -- warn: { name: "Use 'isPrefixOf' from Universum" - , lhs: Data.List.isPrefixOf, rhs: Universum.isPrefixOf } -- warn: { name: "Use 'permutations' from Universum" - , lhs: Data.List.permutations, rhs: Universum.permutations } -- warn: { name: "Use 'sort' from Universum" - , lhs: Data.List.sort, rhs: Universum.sort } -- warn: { name: "Use 'sortBy' from Universum" - , lhs: Data.List.sortBy, rhs: Universum.sortBy } -- warn: { name: "Use 'sortOn' from Universum" - , lhs: Data.List.sortOn, rhs: Universum.sortOn } -- warn: { name: "Use 'subsequences' from Universum" - , lhs: Data.List.subsequences, rhs: Universum.subsequences } -- warn: { name: "Use 'tails' from Universum" - , lhs: Data.List.tails, rhs: Universum.tails } -- warn: { name: "Use 'transpose' from Universum" - , lhs: Data.List.transpose, rhs: Universum.transpose } -- warn: { name: "Use 'unfoldr' from Universum" - , lhs: Data.List.unfoldr, rhs: Universum.unfoldr } - -- warn: { name: "Use 'NonEmpty' from Universum" - , lhs: Data.List.NonEmpty.NonEmpty, rhs: Universum.NonEmpty } -- warn: { name: "Use '(:|)' from Universum" - , lhs: "Data.List.NonEmpty.(:|)", rhs: "Universum.(:|)"} -- warn: { name: "Use 'nonEmpty' from Universum" - , lhs: Data.List.NonEmpty.nonEmpty, rhs: Universum.nonEmpty} -- warn: { name: "Use 'head' from Universum" - , lhs: Data.List.NonEmpty.head, rhs: Universum.head } -- warn: { name: "Use 'init' from Universum" - , lhs: Data.List.NonEmpty.init, rhs: Universum.init } -- warn: { name: "Use 'last' from Universum" - , lhs: Data.List.NonEmpty.last, rhs: Universum.last } -- warn: { name: "Use 'tail' from Universum" - , lhs: Data.List.NonEmpty.tail, rhs: Universum.tail } -- warn: { name: "Use 'sortWith' from Universum" - , lhs: GHC.Exts.sortWith, rhs: Universum.sortWith } - -## Monad -- warn: { name: "Use '(>=>)' from Universum" - , lhs: Control.Monad.(>=>), rhs: Universum.(>=>) } -- warn: { name: "Use '(<=<)' from Universum" - , lhs: Control.Monad.(<=<), rhs: Universum.(<=<) } -- warn: { name: "Use 'forever' from Universum" - , lhs: Control.Monad.forever, rhs: Universum.forever } -- warn: { name: "Use 'join' from Universum" - , lhs: Control.Monad.join, rhs: Universum.join } -- warn: { name: "Use 'mfilter' from Universum" - , lhs: Control.Monad.mfilter, rhs: Universum.mfilter } -- warn: { name: "Use 'filterM' from Universum" - , lhs: Control.Monad.filterM, rhs: Universum.filterM } -- warn: { name: "Use 'mapAndUnzipM' from Universum" - , lhs: Control.Monad.mapAndUnzipM, rhs: Universum.mapAndUnzipM } -- warn: { name: "Use 'zipWithM' from Universum" - , lhs: Control.Monad.zipWithM, rhs: Universum.zipWithM } -- warn: { name: "Use 'zipWithM_' from Universum" - , lhs: Control.Monad.zipWithM_, rhs: Universum.zipWithM_ } -- warn: { name: "Use 'foldM' from Universum" - , lhs: Control.Monad.foldM, rhs: Universum.foldM } -- warn: { name: "Use 'foldM_' from Universum" - , lhs: Control.Monad.foldM_, rhs: Universum.foldM_ } -- warn: { name: "Use 'replicateM' from Universum" - , lhs: Control.Monad.replicateM, rhs: Universum.replicateM } -- warn: { name: "Use 'replicateM_' from Universum" - , lhs: Control.Monad.replicateM_, rhs: Universum.replicateM_ } -- warn: { name: "Use 'liftM2' from Universum" - , lhs: Control.Monad.liftM2, rhs: Universum.liftM2 } -- warn: { name: "Use 'liftM3' from Universum" - , lhs: Control.Monad.liftM3, rhs: Universum.liftM3 } -- warn: { name: "Use 'liftM4' from Universum" - , lhs: Control.Monad.liftM4, rhs: Universum.liftM4 } -- warn: { name: "Use 'liftM5' from Universum" - , lhs: Control.Monad.liftM5, rhs: Universum.liftM5 } -- warn: { name: "Use 'ap' from Universum" - , lhs: Control.Monad.ap, rhs: Universum.ap } -- warn: { name: "Use '(<$!>)' from Universum" - , lhs: Control.Monad.(<$!>), rhs: Universum.(<$!>) } - -- warn: { name: "Use 'ExceptT' from Universum" - , lhs: Control.Monad.Except.ExceptT, rhs: Universum.ExceptT } -- warn: { name: "Use 'runExceptT' from Universum" - , lhs: Control.Monad.Except.runExceptT, rhs: Universum.runExceptT } - -- warn: { name: "Use 'MonadReader' from Universum" - , lhs: Control.Monad.Reader.MonadReader, rhs: Universum.MonadReader } -- warn: { name: "Use 'Reader' from Universum" - , lhs: Control.Monad.Reader.Reader, rhs: Universum.Reader } -- warn: { name: "Use 'ReaderT' from Universum" - , lhs: Control.Monad.Reader.ReaderT, rhs: Universum.ReaderT } -- warn: { name: "Use 'runReaderT' from Universum" - , lhs: Control.Monad.Reader.runReaderT, rhs: Universum.runReaderT } -- warn: { name: "Use 'ask' from Universum" - , lhs: Control.Monad.Reader.ask, rhs: Universum.ask } -- warn: { name: "Use 'local' from Universum" - , lhs: Control.Monad.Reader.local, rhs: Universum.local } -- warn: { name: "Use 'reader' from Universum" - , lhs: Control.Monad.Reader.reader, rhs: Universum.reader } -- warn: { name: "Use 'runReader' from Universum" - , lhs: Control.Monad.Reader.runReader, rhs: Universum.runReader } - -- warn: { name: "Use 'MonadState' from Universum" - , lhs: Control.Monad.State.Strict.MonadState, rhs: Universum.MonadState } -- warn: { name: "Use 'State' from Universum" - , lhs: Control.Monad.State.Strict.State, rhs: Universum.State } -- warn: { name: "Use 'StateT' from Universum" - , lhs: Control.Monad.State.Strict.StateT, rhs: Universum.StateT } -- warn: { name: "Use 'runStateT' from Universum" - , lhs: Control.Monad.State.Strict.runStateT, rhs: Universum.runStateT } -- warn: { name: "Use 'evalState' from Universum" - , lhs: Control.Monad.State.Strict.evalState, rhs: Universum.evalState } -- warn: { name: "Use 'evalStateT' from Universum" - , lhs: Control.Monad.State.Strict.evalStateT, rhs: Universum.evalStateT } -- warn: { name: "Use 'execState' from Universum" - , lhs: Control.Monad.State.Strict.execState, rhs: Universum.execState } -- warn: { name: "Use 'execStateT' from Universum" - , lhs: Control.Monad.State.Strict.execStateT, rhs: Universum.execStateT } -- warn: { name: "Use 'get' from Universum" - , lhs: Control.Monad.State.Strict.get, rhs: Universum.get } -- warn: { name: "Use 'gets' from Universum" - , lhs: Control.Monad.State.Strict.gets, rhs: Universum.gets } -- warn: { name: "Use 'modify' from Universum" - , lhs: Control.Monad.State.Strict.modify, rhs: Universum.modify } -- warn: { name: "Use 'modify'' from Universum" - , lhs: "Control.Monad.State.Strict.modify'", rhs: "Universum.modify'" } -- warn: { name: "Use 'put' from Universum" - , lhs: Control.Monad.State.Strict.put, rhs: Universum.put } -- warn: { name: "Use 'runState' from Universum" - , lhs: Control.Monad.State.Strict.runState, rhs: Universum.runState } -- warn: { name: "Use 'state' from Universum" - , lhs: Control.Monad.State.Strict.state, rhs: Universum.state } -- warn: { name: "Use 'withState' from Universum" - , lhs: Control.Monad.State.Strict.withState, rhs: Universum.withState } - -- warn: { name: "Use 'MonadFail' from Universum" - , lhs: Control.Monad.Fail.MonadFail, rhs: Universum.MonadFail } - - -- warn: { name: "Use 'MonadIO' from Universum" - , lhs: Control.Monad.Trans.MonadIO, rhs: Universum.MonadIO } -- warn: { name: "Use 'MonadTrans' from Universum" - , lhs: Control.Monad.Trans.MonadTrans, rhs: Universum.MonadTrans } -- warn: { name: "Use 'lift' from Universum" - , lhs: Control.Monad.Trans.lift, rhs: Universum.lift } -- warn: { name: "Use 'liftIO' from Universum" - , lhs: Control.Monad.Trans.liftIO, rhs: Universum.liftIO } - -- warn: { name: "Use 'IdentityT' from Universum" - , lhs: Control.Monad.Trans.Identity.IdentityT, rhs: Universum.IdentityT } -- warn: { name: "Use 'runIdentityT' from Universum" - , lhs: Control.Monad.Trans.Identity.runIdentityT, rhs: Universum.runIdentityT } - -- warn: { name: "Use 'MaybeT' from Universum" - , lhs: Control.Monad.Trans.Maybe.MaybeT, rhs: Universum.MaybeT } -- warn: { name: "Use 'maybeToExceptT' from Universum" - , lhs: Control.Monad.Trans.Maybe.maybeToExceptT, rhs: Universum.maybeToExceptT } -- warn: { name: "Use 'exceptToMaybeT' from Universum" - , lhs: Control.Monad.Trans.Maybe.exceptToMaybeT, rhs: Universum.exceptToMaybeT } - -- warn: { name: "Use 'catMaybes' from Universum" - , lhs: Data.Maybe.catMaybes, rhs: Universum.catMaybes } -- warn: { name: "Use 'fromMaybe' from Universum" - , lhs: Data.Maybe.fromMaybe, rhs: Universum.fromMaybe } -- warn: { name: "Use 'isJust' from Universum" - , lhs: Data.Maybe.isJust, rhs: Universum.isJust } -- warn: { name: "Use 'isNothing' from Universum" - , lhs: Data.Maybe.isNothing, rhs: Universum.isNothing } -- warn: { name: "Use 'listToMaybe' from Universum" - , lhs: Data.Maybe.listToMaybe, rhs: Universum.listToMaybe } -- warn: { name: "Use 'mapMaybe' from Universum" - , lhs: Data.Maybe.mapMaybe, rhs: Universum.mapMaybe } -- warn: { name: "Use 'maybeToList' from Universum" - , lhs: Data.Maybe.maybeToList, rhs: Universum.maybeToList } - -- warn: { name: "Use 'isLeft' from Universum" - , lhs: Data.Either.isLeft, rhs: Universum.isLeft } -- warn: { name: "Use 'isRight' from Universum" - , lhs: Data.Either.isRight, rhs: Universum.isRight } -- warn: { name: "Use 'lefts' from Universum" - , lhs: Data.Either.lefts, rhs: Universum.lefts } -- warn: { name: "Use 'partitionEithers' from Universum" - , lhs: Data.Either.partitionEithers, rhs: Universum.partitionEithers } -- warn: { name: "Use 'rights' from Universum" - , lhs: Data.Either.rights, rhs: Universum.rights } - -- warn: { name: "Use 'newTVar' from Universum" - , lhs: Control.Concurrent.STM.TVar.newTVar, rhs: Universum.newTVar } -- warn: { name: "Use 'readTVar' from Universum" - , lhs: Control.Concurrent.STM.TVar.readTVar, rhs: Universum.readTVar } -- warn: { name: "Use 'writeTVar' from Universum" - , lhs: Control.Concurrent.STM.TVar.writeTVar, rhs: Universum.writeTVar } -- warn: { name: "Use 'modifyTVar'' from Universum" - , lhs: "Control.Concurrent.STM.TVar.modifyTVar'", rhs: "Universum.modifyTVar'" } -- warn: { name: "Use 'newTVarIO' from Universum" - , lhs: Control.Concurrent.STM.TVar.newTVarIO, rhs: Universum.newTVarIO } -- warn: { name: "Use 'readTVarIO' from Universum" - , lhs: Control.Concurrent.STM.TVar.readTVarIO, rhs: Universum.readTVarIO } - -- warn: { name: "Use 'newIORef' from Universum" - , lhs: Data.IORef.newIORef, rhs: Universum.newIORef } -- warn: { name: "Use 'readIORef' from Universum" - , lhs: Data.IORef.readIORef, rhs: Universum.readIORef } -- warn: { name: "Use 'writeIORef' from Universum" - , lhs: Data.IORef.writeIORef, rhs: Universum.writeIORef } -- warn: { name: "Use 'modifyIORef' from Universum" - , lhs: Data.IORef.modifyIORef, rhs: Universum.modifyIORef } -- warn: { name: "Use 'modifyIORef'' from Universum" - , lhs: "Data.IORef.modifyIORef'", rhs: "Universum.modifyIORef'" } -- warn: { name: "Use 'atomicModifyIORef' from Universum" - , lhs: Data.IORef.atomicModifyIORef, rhs: Universum.atomicModifyIORef } -- warn: { name: "Use 'atomicModifyIORef'' from Universum" - , lhs: "Data.IORef.atomicModifyIORef'", rhs: "Universum.atomicModifyIORef'" } -- warn: { name: "Use 'atomicWriteIORef' from Universum" - , lhs: Data.IORef.atomicWriteIORef, rhs: Universum.atomicWriteIORef } - -## Monoid -- warn: { name: "Use 'All' from Universum" - , lhs: Data.Monoid.All, rhs: Universum.All } -- warn: { name: "Use 'Alt' from Universum" - , lhs: Data.Monoid.Alt, rhs: Universum.Alt } -- warn: { name: "Use 'Any' from Universum" - , lhs: Data.Monoid.Any, rhs: Universum.Any } -- warn: { name: "Use 'Dual' from Universum" - , lhs: Data.Monoid.Dual, rhs: Universum.Dual } -- warn: { name: "Use 'Endo' from Universum" - , lhs: Data.Monoid.Endo, rhs: Universum.Endo } -- warn: { name: "Use 'First' from Universum" - , lhs: Data.Monoid.First, rhs: Universum.First } -- warn: { name: "Use 'Last' from Universum" - , lhs: Data.Monoid.Last, rhs: Universum.Last } -- warn: { name: "Use 'Product' from Universum" - , lhs: Data.Monoid.Product, rhs: Universum.Product } -- warn: { name: "Use 'Sum' from Universum" - , lhs: Data.Monoid.Sum, rhs: Universum.Sum } - -- warn: { name: "Use 'Option' from Universum" - , lhs: Data.Semigroup.Option, rhs: Universum.Option } -- warn: { name: "Use 'Semigroup' from Universum" - , lhs: Data.Semigroup.Semigroup, rhs: Universum.Semigroup } -- warn: { name: "Use 'sconcat' from Universum" - , lhs: Data.Semigroup.sconcat, rhs: Universum.sconcat } -- warn: { name: "Use 'stimes' from Universum" - , lhs: Data.Semigroup.stimes, rhs: Universum.stimes } -- warn: { name: "Use '(<>)' from Universum" - , lhs: Data.Semigroup.(<>), rhs: Universum.(<>) } -- warn: { name: "Use 'WrappedMonoid' from Universum" - , lhs: Data.Semigroup.WrappedMonoid, rhs: Universum.WrappedMonoid } -- warn: { name: "Use 'cycle1' from Universum" - , lhs: Data.Semigroup.cycle1, rhs: Universum.cycle1 } -- warn: { name: "Use 'mtimesDefault' from Universum" - , lhs: Data.Semigroup.mtimesDefault, rhs: Universum.mtimesDefault } -- warn: { name: "Use 'stimesIdempotent' from Universum" - , lhs: Data.Semigroup.stimesIdempotent, rhs: Universum.stimesIdempotent } -- warn: { name: "Use 'stimesIdempotentMonoid' from Universum" - , lhs: Data.Semigroup.stimesIdempotentMonoid, rhs: Universum.stimesIdempotentMonoid } -- warn: { name: "Use 'stimesMonoid' from Universum" - , lhs: Data.Semigroup.stimesMonoid, rhs: Universum.stimesMonoid } - -## String -- warn: { name: "Use 'ByteString' from Universum" - , lhs: Data.ByteString.ByteString, rhs: Universum.ByteString } -- warn: { name: "Use 'IsString' from Universum" - , lhs: Data.String.IsString, rhs: Universum.IsString } - -- warn: { name: "Use 'Text' from Universum" - , lhs: Data.Text.Text, rhs: Universum.Text } -- warn: { name: "Use 'lines' from Universum" - , lhs: Data.Text.lines, rhs: Universum.lines } -- warn: { name: "Use 'unlines' from Universum" - , lhs: Data.Text.unlines, rhs: Universum.unlines } -- warn: { name: "Use 'words' from Universum" - , lhs: Data.Text.words, rhs: Universum.words } -- warn: { name: "Use 'unwords' from Universum" - , lhs: Data.Text.unwords, rhs: Universum.unwords } - -- warn: { name: "Use 'LText' from Universum" - , lhs: Data.Text.Lazy.Text, rhs: Universum.LText } -- warn: { name: "Use 'LByteString' from Universum" - , lhs: Data.ByteString.Lazy.LByteString, rhs: Universum.LByteString } - -- warn: { name: "Use 'Buildable' from Universum" - , lhs: Data.Text.Buildable, rhs: Universum.Buildable } -- warn: { name: "Use 'decodeUtf8'' from Universum" - , lhs: "Data.Text.Encoding.decodeUtf8'", rhs: "Universum.decodeUtf8'" } -- warn: { name: "Use 'decodeUtf8With' from Universum" - , lhs: Data.Text.Encoding.decodeUtf8With, rhs: Universum.decodeUtf8With } - -- warn: { name: "Use 'OnDecodeError' from Universum" - , lhs: Data.Text.Encoding.Error.OnDecodeError, rhs: Universum.OnDecodeError } -- warn: { name: "Use 'OnDecodeError' from Universum" - , lhs: Data.Text.Encoding.Error.OnDecodeError, rhs: Universum.OnDecodeError } -- warn: { name: "Use 'OnError' from Universum" - , lhs: Data.Text.Encoding.Error.OnError, rhs: Universum.OnError } -- warn: { name: "Use 'UnicodeException' from Universum" - , lhs: Data.Text.Encoding.Error.UnicodeException, rhs: Universum.UnicodeException } -- warn: { name: "Use 'lenientDecode' from Universum" - , lhs: Data.Text.Encoding.Error.lenientDecode, rhs: Universum.lenientDecode } -- warn: { name: "Use 'strictDecode' from Universum" - , lhs: Data.Text.Encoding.Error.strictDecode, rhs: Universum.strictDecode } - -- warn: { name: "Use 'fromStrict' from Universum" - , lhs: Data.Text.Lazy.fromStrict, rhs: Universum.fromStrict } -- warn: { name: "Use 'toStrict' from Universum" - , lhs: Data.Text.Lazy.toStrict, rhs: Universum.toStrict } - -- warn: { name: "Use 'readMaybe' from Universum" - , lhs: Text.Read.readMaybe, rhs: Universum.readMaybe } - -- warn: { name: "Use 'getLine' from Universum" - , lhs: Data.Text.IO.getLine, rhs: Universum.getLine } -- warn: { name: "Use 'readFile' from Universum" - , lhs: Data.Text.IO.readFile, rhs: Universum.readFile } -- warn: { name: "Use 'writeFile' from Universum" - , lhs: Data.Text.IO.writeFile, rhs: Universum.writeFile } -- warn: { name: "Use 'appendFile' from Universum" - , lhs: Data.Text.IO.appendFile, rhs: Universum.appendFile } - -## Unsafe -- warn: { name: "Use 'head' from Universum.Unsafe" - , lhs: Data.List.head, rhs: Universum.Unsafe.head - , note: "Use 'import qualified Universum.Unsafe as Unsafe (head)'" } -- warn: { name: "Use 'tail' from Universum.Unsafe" - , lhs: Data.List.tail, rhs: Universum.Unsafe.tail - , note: "Use 'import qualified Universum.Unsafe as Unsafe (tail)'" } -- warn: { name: "Use 'init' from Universum.Unsafe" - , lhs: Data.List.init, rhs: Universum.Unsafe.init - , note: "Use 'import qualified Universum.Unsafe as Unsafe (init)'" } -- warn: { name: "Use 'last' from Universum.Unsafe" - , lhs: Data.List.last, rhs: Universum.Unsafe.last - , note: "Use 'import qualified Universum.Unsafe as Unsafe (last)'" } -- warn: { name: "Use '(!!)' from Universum.Unsafe" - , lhs: "Data.List.(!!)", rhs: "Universum.Unsafe.(!!)" - , note: "Use 'import qualified Universum.Unsafe as Unsafe ((!!))'" } -- warn: { name: "Use 'fromJust' from Universum.Unsafe" - , lhs: "Data.Maybe.fromJust", rhs: "Universum.Unsafe.fromJust" - , note: "Use 'import qualified Universum.Unsafe as Unsafe (fromJust)'" } - -############################################################################ -## Lifted functions in Universum -############################################################################ - -## concurrency - -- warn: { name: "liftIO is not needed", lhs: liftIO newEmptyMVar, rhs: Universum.newEmptyMVar - , note: "If you import 'newEmptyMVar' from Universum, it's already lifted" } -- warn: { name: "liftIO is not needed", lhs: liftIO (newMVar x), rhs: Universum.newMVar x - , note: "If you import 'newMVar' from Universum, it's already lifted" } -- warn: { name: "liftIO is not needed", lhs: liftIO (putMVar x y), rhs: Universum.putMVar x y - , note: "If you import 'putMVar' from Universum, it's already lifted" } -- warn: { name: "liftIO is not needed", lhs: liftIO (readMVar x), rhs: Universum.readMVar x - , note: "If you import 'readMVar' from Universum, it's already lifted" } -- warn: { name: "liftIO is not needed", lhs: liftIO (swapMVar x y), rhs: Universum.swapMVar x y - , note: "If you import 'swapMVar' from Universum, it's already lifted" } -- warn: { name: "liftIO is not needed", lhs: liftIO (takeMVar x), rhs: Universum.takeMVar x - , note: "If you import 'takeMVar' from Universum, it's already lifted" } -- warn: { name: "liftIO is not needed", lhs: liftIO (tryPutMVar x y), rhs: Universum.tryPutMVar x y - , note: "If you import 'tryPutMVar' from Universum, it's already lifted" } -- warn: { name: "liftIO is not needed", lhs: liftIO (tryReadMVar x), rhs: Universum.tryReadMVar x - , note: "If you import 'tryReadMVar' from Universum, it's already lifted" } -- warn: { name: "liftIO is not needed", lhs: liftIO (tryTakeMVar x), rhs: Universum.tryTakeMVar x - , note: "If you import 'tryTakeMVar' from Universum, it's already lifted" } -- warn: { name: "liftIO is not needed", lhs: liftIO (atomically x), rhs: Universum.atomically x - , note: "If you import 'atomically' from Universum, it's already lifted" } -- warn: { name: "liftIO is not needed", lhs: liftIO (newTVarIO x), rhs: Universum.newTVarIO x - , note: "If you import 'newTVarIO' from Universum, it's already lifted" } -- warn: { name: "liftIO is not needed", lhs: liftIO (readTVarIO x), rhs: Universum.readTVarIO x - , note: "If you import 'readTVarIO' from Universum, it's already lifted" } - -## IORef - -- warn: { name: "liftIO is not needed", lhs: liftIO (newIORef x), rhs: Universum.newIORef x - , note: "If you import 'newIORef' from Universum, it's already lifted" } -- warn: { name: "liftIO is not needed", lhs: liftIO (readIORef x), rhs: Universum.readIORef x - , note: "If you import 'readIORef' from Universum, it's already lifted" } -- warn: { name: "liftIO is not needed", lhs: liftIO (writeIORef x y), rhs: Universum.writeIORef x y - , note: "If you import 'writeIORef' from Universum, it's already lifted" } -- warn: { name: "liftIO is not needed", lhs: liftIO (modifyIORef x y), rhs: Universum.modifyIORef x y - , note: "If you import 'modifyIORef' from Universum, it's already lifted" } -- warn: { name: "liftIO is not needed", lhs: "liftIO (modifyIORef' x y)", rhs: "Universum.modifyIORef' x y" - , note: "If you import 'modifyIORef'' from Universum, it's already lifted" } -- warn: { name: "liftIO is not needed", lhs: liftIO (atomicModifyIORef x y), rhs: Universum.atomicModifyIORef x y - , note: "If you import 'atomicModifyIORef' from Universum, it's already lifted" } -- warn: { name: "liftIO is not needed", lhs: "liftIO (atomicModifyIORef' x y)", rhs: "Universum.atomicModifyIORef' x y" - , note: "If you import 'atomicModifyIORef'' from Universum, it's already lifted" } -- warn: { name: "liftIO is not needed", lhs: liftIO (atomicWriteIORef x y), rhs: Universum.atomicWriteIORef x y - , note: "If you import 'atomicWriteIORef' from Universum, it's already lifted" } - -## others - -- warn: { name: "liftIO is not needed", lhs: liftIO Universum.getLine, rhs: Universum.getLine - , note: "If you import 'getLine' from Universum, it's already lifted" } -- warn: { name: "liftIO is not needed", lhs: liftIO (Universum.readFile x), rhs: Universum.readFile x - , note: "If you import 'readFile' from Universum, it's already lifted" } -- warn: { name: "liftIO is not needed", lhs: liftIO (Universum.writeFile x y), rhs: Universum.writeFile x y - , note: "If you import 'writeFile' from Universum, it's already lifted" } -- warn: { name: "liftIO is not needed", lhs: liftIO (Universum.appendFile x y), rhs: Universum.appendFile x y - , note: "If you import 'appendFile' from Universum, it's already lifted" } -- warn: { name: "liftIO is not needed", lhs: liftIO (Universum.openFile x y), rhs: Universum.openFile x y - , note: "If you import 'openFile' from Universum, it's already lifted" } -- warn: { name: "liftIO is not needed", lhs: liftIO (exitWith x), rhs: Universum.exitWith x - , note: "If you import 'exitWith' from Universum, it's already lifted" } -- warn: { name: "liftIO is not needed", lhs: liftIO exitFailure, rhs: Universum.exitFailure - , note: "If you import 'exitFailure' from Universum, it's already lifted" } -- warn: { name: "liftIO is not needed", lhs: liftIO exitSuccess, rhs: Universum.exitSuccess - , note: "If you import 'exitSuccess' from Universum, it's already lifted" } -- warn: { name: "liftIO is not needed", lhs: liftIO (die x), rhs: Universum.die x - , note: "If you import 'die' from Universum, it's already lifted" } -- warn: { name: "liftIO is not needed", lhs: liftIO (stToIO x), rhs: Universum.stToIO x - , note: "If you import 'stToIO' from Universum, it's already lifted" } diff --git a/Readme.md b/Readme.md index 1960b51..0f66439 100644 --- a/Readme.md +++ b/Readme.md @@ -20,48 +20,23 @@ repositories in `config.toml`, then visit `localhost:8080/admin/overview`. ## 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 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. - -### 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/). - -Run - -``` -stack build -``` - -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 +### Build using cabal -``` -stack install -``` +Build using -Alternatively, run `walint` via stack: +~~~sh +cabal build [all|walint|server] +~~~ -``` -stack run -- walint [options as normal] -``` +There are no version bounds in the cabal files, but the `cabal.project` file +tells cabal to follow a stackage snapshot. -### Build using cabal +### Build using Nix -You can, but probably should not. Beware of older Aeson versions! +Since nixpkgs also follows stackage snapshots, building the packages with Nix +should work without difficulty; just pass a nixpkgs to `default.nix` which does +not diverge too much from the currently-used stackage snapshot (aim is that +stable nixpkgs should work). ## Usage ``` sh diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..c5b41d4 --- /dev/null +++ b/cabal.project @@ -0,0 +1,2 @@ +packages: */*.cabal +import: https://www.stackage.org/lts-20.26/cabal.config diff --git a/default.nix b/default.nix index 566e710..95764eb 100644 --- a/default.nix +++ b/default.nix @@ -1,53 +1,18 @@ -{ nixpkgs ? import {}, compiler ? "default", doBenchmark ? false }: +{ nixpkgs ? import {}, compiler ? "default" }: let 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 {}); + inherit (haskellPackages) callPackage; -in - drv +in rec { + tiled = callPackage ./tiled {}; + walint = callPackage ./walint { inherit tiled; }; + walint-cli = callPackage ./walint-cli { inherit walint; }; + server = callPackage ./server { inherit walint; }; +} diff --git a/flake.lock b/flake.lock deleted file mode 100644 index 59b96a7..0000000 --- a/flake.lock +++ /dev/null @@ -1,27 +0,0 @@ -{ - "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 -} diff --git a/flake.nix b/flake.nix deleted file mode 100644 index fc2f168..0000000 --- a/flake.nix +++ /dev/null @@ -1,12 +0,0 @@ -{ - 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"; }; - }; - }; -} diff --git a/lib/Badges.hs b/lib/Badges.hs deleted file mode 100644 index d6afc43..0000000 --- a/lib/Badges.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - --- | module defining Badge types and utility functions -module Badges where - -import Universum - -import Data.Aeson (Options (fieldLabelModifier, sumEncoding), - SumEncoding (UntaggedValue), ToJSON (toJSON), - defaultOptions, genericToJSON, (.=)) -import qualified Data.Aeson as A -import Data.Char (toLower) -import Text.Regex.TDFA ((=~)) - - -data BadgeArea = - BadgePoint - { areaX :: Double - , areaY :: Double - } - | BadgeRect - { areaX :: Double - , areaY :: Double - , areaWidth :: Double - , areaHeight :: Double - } - deriving (Ord, Eq, Generic, Show, NFData) - -newtype BadgeToken = BadgeToken Text - deriving newtype (Eq, Ord, Show, NFData) - -instance ToJSON BadgeArea where - toJSON = genericToJSON defaultOptions - { fieldLabelModifier = drop 4 . map toLower - , sumEncoding = UntaggedValue } - -instance ToJSON BadgeToken where - toJSON (BadgeToken text) = toJSON text - -parseToken :: Text -> Maybe BadgeToken -parseToken text = if text =~ ("^[a-zA-Z0-9]{50}$" :: Text) - then Just (BadgeToken text) - else Nothing - -data Badge = Badge BadgeToken BadgeArea - deriving (Ord, Eq, Generic, Show, NFData) - -instance ToJSON Badge where - toJSON (Badge token area) = A.object $ case area of - BadgePoint x y -> [ "x" .= x - , "y" .= y - , "token" .= token - , "type" .= A.String "point" - ] - BadgeRect {..} -> [ "x" .= areaX - , "y" .= areaY - , "token" .= token - , "width" .= areaWidth - , "height" .= areaHeight - , "type" .= A.String "rectangle" - ] diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs deleted file mode 100644 index 104fdae..0000000 --- a/lib/CheckDir.hs +++ /dev/null @@ -1,284 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - --- | Module that contains high-level checking for an entire directory -module CheckDir ( maximumLintLevel - , recursiveCheckDir - , DirResult (..) - , MissingAsset(..) - , MissingDep(..) - , resultIsFatal - ,shrinkDirResult) where - -import Universum hiding (Set) - -import CheckMap (MapResult (..), Optional, - ResultKind (..), loadAndLintMap, - shrinkMapResult) -import Control.Monad.Extra (mapMaybeM) -import Data.Aeson (ToJSON, (.=)) -import qualified Data.Aeson as A -import Data.List (partition) -import qualified Data.Map as M -import Data.Map.Strict (mapKeys, mapWithKey, (\\)) -import Data.Text (isInfixOf) -import qualified Data.Text as T -import Data.Tiled (Tiledmap) -import Dirgraph (graphToDot, invertGraph, resultToGraph, - takeSubGraph, unreachableFrom) -import LintConfig (LintConfig', configMaxLintLevel) -import Paths (normalise, normaliseWithFrag) -import System.Directory.Extra (doesFileExist) -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), - Level (..), hintLevel) -import Util (PrettyPrint (prettyprint), ellipsis) - - --- based on the startling observation that Data.Map has lower complexity --- for difference than Data.Set, but the same complexity for fromList -type Set a = Map a () -setFromList :: Ord a => [a] -> Set a -setFromList = M.fromList . flip zip (repeat ()) -listFromSet :: Set a -> [a] -listFromSet = map fst . M.toList - --- | Result of linting an entire directory / repository -data DirResult (complete :: ResultKind) = DirResult - { dirresultMaps :: Map FilePath (MapResult complete) - -- ^ all maps of this respository, by (local) filepath - , dirresultDeps :: [MissingDep] - -- ^ all dependencies to things outside this repository - , dirresultMissingAssets :: [MissingAsset] - -- ^ entrypoints of maps which are referred to but missing - , dirresultGraph :: Text - } deriving (Generic) - -instance NFData (Optional a (Maybe Tiledmap)) => NFData (DirResult a) - - -data MissingDep = MissingDep - { depFatal :: Maybe Bool - , entrypoint :: Text - , neededBy :: [FilePath] - } deriving (Generic, ToJSON, NFData) - --- | Missing assets are the same thing as missing dependencies, --- but should not be confused (and also serialise differently --- to json) -newtype MissingAsset = MissingAsset MissingDep - deriving (Generic, NFData) - - --- | "shrink" the result by throwing the adjusted tiledmaps away -shrinkDirResult :: DirResult Full -> DirResult Shrunk -shrinkDirResult !res = - res { dirresultMaps = fmap shrinkMapResult (dirresultMaps res) } - --- | given this config, should the result be considered to have failed? -resultIsFatal :: LintConfig' -> DirResult Full -> Bool -resultIsFatal config res = - not (null (dirresultMissingAssets res) || not (any (isJust . depFatal) (dirresultDeps res))) - || maximumLintLevel res > configMaxLintLevel config - --- | maximum lint level that was observed anywhere in any map. --- note that it really does go through all lints, so don't --- call it too often -maximumLintLevel :: DirResult a -> Level -maximumLintLevel res - | not (null (dirresultMissingAssets res)) = Fatal - | otherwise = - (maybe Info maximum . nonEmpty) - . map hintLevel - . concatMap (\map -> keys (mapresultLayer map) - <> keys (mapresultTileset map) - <> mapresultGeneral map - ) - . elems - . dirresultMaps - $ res - - - -instance ToJSON (DirResult a) where - toJSON res = A.object [ - "result" .= A.object - [ "missingDeps" .= dirresultDeps res - , "missingAssets" .= dirresultMissingAssets res - -- some repos have auto-generated maps which are basically all the - -- same; aggregate those to reduce output size - , "mapLints" .= (M.fromList - . fmap (first (ellipsis 6)) - . foldr aggregateSameResults [] - . M.toList - $ dirresultMaps res) - , "exitGraph" .= dirresultGraph res - ] - , "severity" .= maximumLintLevel res - , "mapInfo" .= fmap (\tm -> A.object [ "badges" .= mapresultBadges tm ]) - (dirresultMaps res) - ] - where - aggregateSameResults (path,res) acc = - case partition (\(_,res') -> res == res') acc of - ([],_) -> ([toText path], res):acc - ((paths,_):_,acc') -> (toText path:paths, res) : acc' - -instance ToJSON MissingAsset where - toJSON (MissingAsset md) = A.object - [ "asset" .= entrypoint md - , "neededBy" .= neededBy md - ] - - -instance PrettyPrint (Level, DirResult a) where - prettyprint (level, res) = prettyMapLints <> prettyMissingDeps - where - prettyMissingDeps = if not (null (dirresultDeps res)) - then "\nDependency Errors:\n" <> foldMap prettyprint (dirresultDeps res) - else "" - prettyMapLints = T.concat - (map prettyLint $ M.toList $ dirresultMaps res) - prettyLint :: (FilePath, MapResult a) -> Text - prettyLint (p, lint) = - "\nin " <> toText p <> ":\n" <> prettyprint (level, lint) - -instance PrettyPrint MissingDep where - prettyprint (MissingDep _ f n) = - " - " <> f <> " does not exist, but is required by " - <> prettyDependents <> "\n" - where - prettyDependents = - T.intercalate "," $ map toText n - - --- | check an entire repository -recursiveCheckDir - :: LintConfig' - -> FilePath - -- ^ the repository's prefix (i.e. path to its directory) - -> FilePath - -- ^ the repository's entrypoint (filename of a map, from the repo's root) - -> IO (DirResult Full) -recursiveCheckDir config prefix root = do - maps <- recursiveCheckDir' config prefix [root] mempty - - let exitGraph = resultToGraph maps - -- maps that don't have (local) ways back to the main entrypoint - let nowayback = - unreachableFrom root - . invertGraph - $ exitGraph - - -- inject warnings for maps that have no way back to the entrypoint - let maps' = flip mapWithKey maps $ \path res -> - if path `elem` nowayback - then res { mapresultGeneral = - Hint Warning ("Cannot go back to " <> toText root <> " from this map.") - : mapresultGeneral res - } - else res - - mAssets <- missingAssets prefix maps' - pure $ DirResult { dirresultDeps = missingDeps root maps' - , dirresultMissingAssets = mAssets - , dirresultMaps = maps' - , dirresultGraph = - toText - . showDot - . graphToDot - . takeSubGraph 7 root - $ exitGraph - } - - --- | Given a (partially) completed DirResult, check which local --- maps are referenced but do not actually exist. -missingDeps :: FilePath -> Map FilePath (MapResult a) -> [MissingDep] -missingDeps entrypoint maps = - let simple = M.insert (toText entrypoint) [] used \\ M.union defined trivial - in M.foldMapWithKey (\f n -> [MissingDep (Just $ not ("#" `isInfixOf` f)) f n]) simple - where - -- which maps are linked somewhere? - used :: Map Text [FilePath] - used = M.fromList - $ M.foldMapWithKey - (\path v -> map (, [path]) . mapMaybe (extractLocalDeps path) . mapresultDepends $ v) - maps - where extractLocalDeps prefix = \case - LocalMap name -> Just $ toText $ normaliseWithFrag prefix name - _ -> Nothing - -- which are defined using startLayer? - defined :: Set Text - defined = setFromList - $ M.foldMapWithKey - (\k v -> map ((toText k <> "#") <>) . mapresultProvides $ v) - maps - -- each map file is an entrypoint by itself - trivial = mapKeys toText $ void maps - --- | Checks if all assets referenced in the result actually exist as files -missingAssets :: FilePath -> Map FilePath (MapResult a) -> IO [MissingAsset] -missingAssets prefix maps = - mapM (fmap (fmap (fmap MissingAsset)) missingOfMap) (M.toList maps) <&> fold - where missingOfMap (path, mapres) = mapMaybeM - (\case Local relpath -> - let asset = normalise (takeDirectory path) relpath - in doesFileExist (prefix asset) <&> - \case True -> Nothing - False -> Just $ MissingDep Nothing (toText asset) [path] - _ -> pure Nothing) - (mapresultDepends mapres) - - --- | recursive checking of all maps in a repository -recursiveCheckDir' - :: LintConfig' - -> FilePath - -- ^ the repo's directory - -> [FilePath] - -- ^ paths of maps yet to check - -> Map FilePath (MapResult Full) - -- ^ accumulator for map results - -> IO (Map FilePath (MapResult Full)) -recursiveCheckDir' config prefix paths !acc = do - - -- lint all maps in paths. The double fmap skips maps which cause IO errors - -- (in which case loadAndLintMap returns Nothing); appropriate warnings will - -- show up later during dependency checks - lints <- - let lintPath p = fmap (fmap (p,)) (loadAndLintMap config (prefix p) depth) - where depth = length (splitPath p) - 1 - in mapMaybeM lintPath paths >>= evaluateNF - - - let mapdeps = setFromList (concatMap extractDeps lints) - where extractDeps (mappath, lintresult) = - fmap (FP.normalise . normalise (takeDirectory mappath)) - . mapMaybe onlyLocalMaps - $ mapresultDepends lintresult - onlyLocalMaps = \case - LocalMap p -> Just p - _ -> Nothing - - let acc' = acc <> M.fromList lints - - -- newly found maps that still need to be checked - let unknowns = listFromSet $ M.difference mapdeps acc - - -- no further maps? return acc'. Otherwise, recurse - case unknowns of - [] -> pure acc' - _ -> recursiveCheckDir' config prefix unknowns acc' diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs deleted file mode 100644 index a2a0f9f..0000000 --- a/lib/CheckMap.hs +++ /dev/null @@ -1,234 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - --- | Module that contains the high-level checking functions -module CheckMap (loadAndLintMap, MapResult(..), ResultKind(..), Optional,shrinkMapResult) where - -import Universum - -import Data.Aeson (ToJSON (toJSON)) -import qualified Data.Aeson as A -import Data.Aeson.Types ((.=)) -import qualified Data.Map as M -import qualified Data.Text as T -import qualified Data.Vector as V - - -import Badges (Badge) -import Data.Tiled (Layer (layerLayers, layerName), - Tiledmap (tiledmapLayers, tiledmapTilesets), - loadTiledmap) -import LintConfig (LintConfig (..), LintConfig') -import LintWriter (LintResult, invertLintResult, - resultToAdjusted, resultToBadges, - resultToCWs, resultToDeps, resultToJitsis, - resultToLints, resultToOffers, runLintWriter) -import Properties (checkLayer, checkMap, checkTileset) -import System.FilePath (takeFileName) -import Types (Dep (MapLink), - Hint (Hint, hintLevel, hintMsg), Level (..), - lintsToHints) -import Util (PrettyPrint (prettyprint), prettyprint) - - -data ResultKind = Full | Shrunk - -type family Optional (a :: ResultKind) (b :: Type) where - Optional Full b = b - Optional Shrunk b = () - --- | What this linter produces: lints for a single map -data MapResult (kind :: ResultKind) = MapResult - { mapresultLayer :: Map Hint [Text] - -- ^ lints that occurred in one or more layers - , mapresultTileset :: Map Hint [Text] - -- ^ lints that occurred in one or more tilesets - , mapresultDepends :: [Dep] - -- ^ (external and local) dependencies of this map - , mapresultProvides :: [Text] - -- ^ entrypoints provided by this map (needed for dependency checking) - , mapresultAdjusted :: Optional kind (Maybe Tiledmap) - -- ^ the loaded map, with adjustments by the linter - , mapresultBadges :: [Badge] - -- ^ badges that can be found on this map - , mapresultCWs :: [Text] - -- ^ collected CWs that apply to this map - , mapresultJitsis :: [Text] - -- ^ all jitsi room slugs mentioned in this map - , mapresultGeneral :: [Hint] - -- ^ general-purpose lints that didn't fit anywhere else - } deriving (Generic) - -instance NFData (Optional a (Maybe Tiledmap)) => NFData (MapResult a) - - -instance Eq (MapResult a) where - a == b = - mapresultLayer a == mapresultLayer b && - mapresultTileset a == mapresultTileset b && - -- mapresultBadges a == mapresultBadges b && - mapresultGeneral a == mapresultGeneral b - - -instance ToJSON (MapResult a) where - toJSON res = A.object - [ "layer" .= CollectedLints (mapresultLayer res) - , "tileset" .= CollectedLints (mapresultTileset res) - , "general" .= mapresultGeneral res - ] - -newtype CollectedLints = CollectedLints (Map Hint [Text]) - -instance ToJSON CollectedLints where - toJSON (CollectedLints col) = toJSON - . M.mapKeys hintMsg - $ M.mapWithKey (\h cs -> A.object [ "level" .= hintLevel h, "in" .= truncated cs ]) col - where truncated cs = if length cs > 10 - then take 9 cs <> [ "..." ] - else cs - - -shrinkMapResult :: MapResult Full -> MapResult Shrunk -shrinkMapResult !res = res { mapresultAdjusted = () } - --- | this module's raison d'être --- Lints the map at `path`, and limits local links to at most `depth` --- layers upwards in the file hierarchy -loadAndLintMap :: LintConfig' -> FilePath -> Int -> IO (Maybe (MapResult Full)) -loadAndLintMap config path depth = loadTiledmap path <&> \case - 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) - --- | lint a loaded map -runLinter :: Bool -> LintConfig' -> Tiledmap -> Int -> MapResult Full -runLinter isMain config@LintConfig{..} tiledmap depth = MapResult - { mapresultLayer = invertThing layer - , mapresultTileset = invertThing tileset - , mapresultGeneral = - [Hint Warning "main.json should link back to the lobby" - | isMain && not (any linksLobby layerDeps)] - <> lintsToHints (resultToLints generalResult) - , mapresultDepends = resultToDeps generalResult - <> layerDeps - <> concatMap resultToDeps tileset - , mapresultProvides = concatMap resultToOffers layer - , mapresultAdjusted = Just adjustedMap - , mapresultCWs = resultToCWs generalResult - , mapresultJitsis = concatMap resultToJitsis tileset - <> concatMap resultToJitsis layer - , mapresultBadges = concatMap resultToBadges layer - <> resultToBadges generalResult - } - where - linksLobby = \case - MapLink link -> - ("/@/"<>configEventSlug<>"/lobby") `T.isPrefixOf` link - || configAssemblyTag == "lobby" - _ -> False - layerDeps = concatMap resultToDeps layer - layer = checkLayerRec config depth (V.toList $ tiledmapLayers tiledmap) - tileset = checkThing tiledmapTilesets checkTileset - generalResult = runLintWriter config tiledmap depth checkMap - - checkThing getter checker = V.toList . V.map runCheck $ getter tiledmap - where runCheck thing = runLintWriter config thing depth checker - - -- | "inverts" a LintResult, i.e. groups it by lints instead of - -- layers / maps - invertThing thing = M.unionsWith (<>) $ fmap invertLintResult thing - - adjustedMap = (resultToAdjusted generalResult) - { tiledmapLayers = V.fromList - . fmap resultToAdjusted - $ take (length (tiledmapLayers tiledmap)) layer - , tiledmapTilesets = V.fromList - . fmap resultToAdjusted - $ tileset - } - --- | Recursively checks a layer. --- --- This is apparently necessary because someone thought it would be a good --- idea to have group layers, even if their entire semantics appear to be --- "they're group layers"; they don't seem to /do/ anything … --- --- Note that this will flatten the layer structure and give them all back --- in a single list, but the ones that were passed in will always be at --- the head of the list. -checkLayerRec :: LintConfig' -> Int -> [Layer] -> [LintResult Layer] -checkLayerRec config depth layers = - -- reordering to get the correct ones back up front - (\rs -> fmap fst rs <> concatMap snd rs) - -- map over all input layers - $ flip fmap layers $ \parent -> - case layerLayers parent of - -- not a group layer; just lint this one - Nothing -> - (runLintWriter config parent depth checkLayer,[]) - -- this is a group layer. Fun! - Just sublayers -> - (parentResult, subresults) - where - -- Lintresults for sublayers with adjusted names - subresults :: [LintResult Layer] - subresults = - take (length sublayers) - . fmap (fmap (\l -> l { layerName = layerName parent <> "/" <> layerName l } )) - $ subresults' - - -- Lintresults for sublayers and subsublayers etc. - subresults' = - checkLayerRec config depth sublayers - - -- lintresult for the parent layer - parentResult = runLintWriter config parentAdjusted depth checkLayer - - -- the parent layer with adjusted sublayers - parentAdjusted = - parent { layerLayers = Just (fmap resultToAdjusted subresults') } - - - --- human-readable lint output, e.g. for consoles -instance PrettyPrint (Level, MapResult a) where - prettyprint (_, mapResult) = if complete == "" - then " all good!\n" else complete - where - complete = T.concat $ prettyGeneral - <> prettyLints mapresultLayer - <> prettyLints mapresultTileset - - -- | pretty-prints a collection of Hints, printing each - -- Hint only once, then a list of its occurences line-wrapped - -- to fit onto a decent-sized terminal - prettyLints :: (MapResult a -> Map Hint [Text]) -> [Text] - prettyLints getter = fmap - (\(h, cs) -> prettyprint h - <> "\n (in " - <> snd (foldl (\(l,a) c -> case l of - 0 -> (T.length c, c) - _ | l < 70 -> (l+2+T.length c, a <> ", " <> c) - _ -> (6+T.length c, a <> ",\n " <> c) - ) - (0, "") cs) - <> ")\n") - (M.toList . getter $ mapResult) - - prettyGeneral :: [Text] - prettyGeneral = map - ((<> "\n") . prettyprint) - $ mapresultGeneral mapResult diff --git a/lib/Dirgraph.hs b/lib/Dirgraph.hs deleted file mode 100644 index cc140a3..0000000 --- a/lib/Dirgraph.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TupleSections #-} - --- | Simple directed graphs, for dependency checking -module Dirgraph where - -import Universum - -import CheckMap (MapResult (mapresultDepends)) -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 qualified Text.Dot as D -import Text.Dot (Dot, (.->.)) -import Types (Dep (LocalMap)) - --- | a simple directed graph -type Graph a = Map a (Set a) - -nodes :: Graph a -> Set a -nodes = M.keysSet - --- | simple directed graph of exits -resultToGraph :: Map FilePath (MapResult a) -> Graph FilePath -resultToGraph = fmap (S.fromList . mapMaybe onlyLocalMaps . mapresultDepends) - where onlyLocalMaps = \case - LocalMap path -> Just (normalise "" path) - _ -> Nothing - --- | invert edges of a directed graph -invertGraph :: (Eq a, Ord a) => Graph a -> Graph a -invertGraph graph = mapWithKey collectFroms graph - where collectFroms to _ = S.fromList . elems . mapMaybeWithKey (select to) $ graph - select to from elems = if to `elem` elems then Just from else Nothing - --- | all nodes reachable from some entrypoint -reachableFrom :: Ord a => a -> Graph a -> Set a -reachableFrom entrypoint graph = recursive mempty (S.singleton entrypoint) - where recursive seen current - | null current = seen - | otherwise = recursive (S.union seen current) (next \\ seen) - where next = S.unions - . S.fromList -- for some reason set is not filterable? - . mapMaybe (`M.lookup` graph) - . S.toList - $ current - -unreachableFrom :: Ord a => a -> Graph a -> Set a -unreachableFrom entrypoint graph = - nodes graph \\ reachableFrom entrypoint graph - -takeSubGraph :: (Eq a, Ord a) => Int -> a -> Graph a -> Graph a -takeSubGraph i start graph - | i <= 0 = mempty - | i == 1 = - M.singleton start reachable - `M.union` M.fromList ((,mempty) <$> S.toList reachable) - | otherwise = - M.singleton start reachable - `M.union` (M.unionsWith S.union - . S.map (flip (takeSubGraph (i-1)) graph) - $ reachable) - where reachable = fromMaybe mempty (M.lookup start graph) - -graphToDot :: Graph FilePath -> Dot () -graphToDot graph = do - main <- D.node [("label","main.json")] - nodes' <- M.traverseMaybeWithKey - (\name edges -> if name /= "main.json" - then D.node [("label",name)] <&> (, edges) <&> Just - else pure Nothing - ) - graph - - let reachable = fromMaybe mempty (M.lookup "main.json" graph) - let nodes = M.insert "main.json" (main,reachable) nodes' - forM_ nodes $ \(node, edges) -> - forM_ edges $ \key -> - case M.lookup key nodes of - Just (other,_) -> node .->. other - _ -> pure () diff --git a/lib/LayerData.hs b/lib/LayerData.hs deleted file mode 100644 index 82efbfc..0000000 --- a/lib/LayerData.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module LayerData where - -import Universum hiding (maximum, uncons) - -import Control.Monad.Zip (mzipWith) -import Data.Set (insert) -import Data.Tiled (GlobalId (unGlobalId), Layer (..)) -import Data.Vector (maximum, uncons) -import qualified Text.Show as TS -import Util (PrettyPrint (..)) - --- | A collision between two layers of the given names. --- Wrapped in a newtype so that Eq can ignore the order of the two -newtype Collision = Collision { fromCollision :: (Text, Text) } - deriving Ord - -instance Eq Collision where - (Collision (a,b)) == (Collision (a',b')) = ((a,b) == (a',b')) || ((a,b) == (b',a')) - -instance PrettyPrint Collision where - prettyprint (Collision (a,b)) = a <> " and " <> b - -instance TS.Show Collision where - show c = toString $ prettyprint c - --- | Finds pairwise tile collisions between the given layers. -layerOverlaps :: Vector Layer -> Set Collision -layerOverlaps layers = case uncons layers of - Nothing -> mempty - Just (l, ls) -> - fst . foldr overlapBetween (mempty, l) $ ls - where overlapBetween :: Layer -> (Set Collision, Layer) -> (Set Collision, Layer) - overlapBetween layer (acc, oldlayer) = - (if collides then insert collision acc else acc, layer) - where - collision = Collision (layerName layer, layerName oldlayer) - collides = case (layerData layer, layerData oldlayer) of - (Just d1, Just d2) -> - 0 /= maximum (mzipWith (\a b -> unGlobalId a * unGlobalId b) d1 d2) - _ -> False diff --git a/lib/LintConfig.hs b/lib/LintConfig.hs deleted file mode 100644 index b0fa3b0..0000000 --- a/lib/LintConfig.hs +++ /dev/null @@ -1,193 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | Module that deals with handling config options -module LintConfig (LintConfig(..), LintConfig', ConfigKind (..), patchConfig,stuffConfig,feedConfig) where - -import Universum - -import Data.Aeson (FromJSON (parseJSON), Options (..), - defaultOptions, eitherDecode) -import Data.Aeson.Types (genericParseJSON) -import qualified Data.ByteString.Char8 as C8 -import qualified Data.ByteString.Lazy as LB -import qualified Data.Map.Strict as M -import GHC.Generics (Generic (Rep, from, to), K1 (..), - M1 (..), (:*:) (..)) -import Types (Level) -import Uris (SchemaSet, - Substitution (DomainSubstitution)) -import WithCli.Pure (Argument (argumentType, parseArgument)) - - - -data ConfigKind = Complete | Basic | Skeleton | Patch - --- | a field that must be given in configs for both server & standalone linter -type family ConfigField (f::ConfigKind) a where - ConfigField Patch a = Maybe a - ConfigField _ a = a - --- | a field that must be given for the standalone linter, but not the server --- (usually because the server will infer them from its own config) -type family StandaloneField (f :: ConfigKind) a where - StandaloneField Complete a = a - StandaloneField Skeleton a = a - StandaloneField _ a = Maybe a - --- | a field specific to a single world / assembly -type family WorldField (f :: ConfigKind) a where - WorldField Complete a = a - WorldField _ a = Maybe a - -data LintConfig (f :: ConfigKind) = LintConfig - { configScriptInject :: ConfigField f (Maybe Text) - -- ^ Link to Script that should be injected - , configAssemblyTag :: WorldField f Text - -- ^ Assembly name (used for jitsiRoomAdminTag) - , configAssemblies :: StandaloneField f [Text] - -- ^ list of all assembly slugs (used to lint e.g. world:// links) - , configEventSlug :: StandaloneField f Text - -- ^ slug of this event (used e.g. to resolve world:// links) - , configMaxLintLevel :: ConfigField f Level - -- ^ Maximum warn level allowed before the lint fails - , configDontCopyAssets :: ConfigField f Bool - -- ^ Don't copy map assets (mostly useful for development) - , configAllowScripts :: ConfigField f Bool - -- ^ Allow defining custom scripts in maps - , configUriSchemas :: ConfigField f SchemaSet - } deriving (Generic) - -type LintConfig' = LintConfig Complete - -deriving instance Show (LintConfig Complete) -deriving instance Show (LintConfig Skeleton) -deriving instance Show (LintConfig Patch) -instance NFData (LintConfig Basic) - -aesonOptions :: Options -aesonOptions = defaultOptions - { omitNothingFields = True - , rejectUnknownFields = True - , fieldLabelModifier = drop 6 - } - -instance FromJSON (LintConfig Complete) where - parseJSON = genericParseJSON aesonOptions - -instance FromJSON (LintConfig Patch) where - parseJSON = genericParseJSON aesonOptions - -instance FromJSON (LintConfig Basic) where - parseJSON = genericParseJSON aesonOptions - - - --- | generic typeclass for things that are "patchable" -class GPatch i m where - gappend :: i p -> m p -> i p - --- generic instances. It's category theory, but with confusing names! -instance GPatch (K1 a k) (K1 a (Maybe k)) where - gappend _ (K1 (Just k')) = K1 k' - gappend (K1 k) (K1 Nothing) = K1 k - {-# INLINE gappend #-} - -instance (GPatch i o, GPatch i' o') - => GPatch (i :*: i') (o :*: o') where - gappend (l :*: r) (l' :*: r') = gappend l l' :*: gappend r r' - {-# INLINE gappend #-} - -instance GPatch i o - => GPatch (M1 _a _b i) (M1 _a' _b' o) where - gappend (M1 x) (M1 y) = M1 (gappend x y) - {-# INLINE gappend #-} - - --- | A patch function. For (almost) and a :: * -> *, --- take an a Identity and an a Maybe, then replace all appropriate --- values in the former with those in the latter. --- --- There isn't actually any useful reason for this function to be this --- abstract, I just wanted to play around with higher kinded types for --- a bit. -patch :: - ( Generic (f Patch) - , Generic (f Complete) - , GPatch (Rep (f Complete)) - (Rep (f Patch)) - ) - => f Complete - -> f Patch - -> f Complete -patch x y = to (gappend (from x) (from y)) - -patchConfig - :: LintConfig Complete - -> Maybe (LintConfig Patch) - -> LintConfig Complete -patchConfig config p = expandWorlds config' - where - config' = case p of - Just p -> patch config p - Nothing -> config - - --- | feed a basic server config -feedConfig - :: LintConfig Basic - -> [Text] - -> Text - -> LintConfig Skeleton -feedConfig LintConfig{..} worlds eventslug = expandWorlds $ - LintConfig - { configAssemblies = worlds - , configEventSlug = eventslug - , .. } - --- | stuff a -stuffConfig :: LintConfig Skeleton -> Text -> LintConfig Complete -stuffConfig LintConfig{..} assemblyslug = - LintConfig - { configAssemblyTag = assemblyslug - , ..} - -class HasWorldList (a :: ConfigKind) -instance HasWorldList 'Complete -instance HasWorldList 'Skeleton - --- kinda sad that ghc can't solve these contraints automatically, --- though i guess it also makes sense … -expandWorlds - :: ( ConfigField a SchemaSet ~ SchemaSet - , StandaloneField a [Text] ~ [Text] - , StandaloneField a Text ~ Text - , HasWorldList a) - => LintConfig a -> LintConfig a -expandWorlds config = config { configUriSchemas = configUriSchemas' } - where - configUriSchemas' = - M.insert "world:" [assemblysubsts] (configUriSchemas config) - assemblysubsts = - DomainSubstitution (M.fromList generated) ["map"] - where generated = configAssemblies config - <&> \slug -> (slug, "/@/"<>configEventSlug config<>"/"<>slug) - -instance (FromJSON (LintConfig a)) => Argument (LintConfig a) where - parseArgument str = - case eitherDecode (LB.fromStrict $ C8.pack str) of - Left _ -> Nothing - Right res -> Just res - - argumentType Proxy = "LintConfig" diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs deleted file mode 100644 index afcec65..0000000 --- a/lib/LintWriter.hs +++ /dev/null @@ -1,198 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TupleSections #-} -{-# OPTIONS_GHC -Wno-missing-signatures #-} - --- | a monad that collects warnings, outputs, etc, -module LintWriter - ( runLintWriter - , LintWriter - , LintWriter' - , LintResult - , invertLintResult - , zoom - -- * working with lint results - , resultToDeps - , resultToOffers - , resultToBadges - , resultToLints - , resultToAdjusted - -- * Add lints to a linter - , info - , suggest - , warn - , forbid - , complain - -- * add other information to the linter - , offersEntrypoint - , offersBadge - , dependsOn - -- * get information about the linter's context - , askContext - , askFileDepth - , lintConfig - -- * adjust the linter's context - , adjust - ,offersCWs,resultToCWs,offersJitsi,resultToJitsis) where - -import Universum - - -import Badges (Badge) -import Data.Map (fromListWith) -import Data.Tiled.Abstract (HasName (getName)) -import LintConfig (LintConfig') -import Types (Dep, Hint, Level (..), Lint (..), hint, - lintsToHints) - - --- | A monad modelling the main linter features -type LintWriter ctxt = LintWriter' ctxt () --- | A linter that can use pure / return things monadically -type LintWriter' ctxt res = - StateT (LinterState ctxt) (Reader (Context, ctxt, LintConfig')) res - --- | A Linter's state: some context (which it may adjust), and a list of lints --- | it already collected. -newtype LinterState ctxt = LinterState - { fromLinterState :: ([Lint], ctxt)} - deriving Functor - --- | The result of running a linter: an adjusted context, and a list of lints. --- | This is actually just a type synonym of LinterState, but kept seperately --- | for largely historic reasons since I don't think I'll change it again -type LintResult ctxt = LinterState ctxt - --- | for now, all context we have is how "deep" in the directory tree --- we currently are -type Context = Int - --- | run a linter. Returns the adjusted context, and a list of lints -runLintWriter - :: LintConfig' -> ctxt -> Context -> LintWriter ctxt -> LintResult ctxt -runLintWriter config context depth linter = LinterState - . fromLinterState - . snd - . runReader runstate - $ (depth, context, config) - where runstate = runStateT linter (LinterState ([], context)) - - -zoom :: (a -> b) -> (b -> a) -> LintWriter a -> LintWriter' b a -zoom embed extract operation = do - config <- lintConfig id - depth <- askFileDepth - let result ctxt = runLintWriter config ctxt depth operation - LinterState (lints,a) <- get - let res = result . extract $ a - put $ LinterState - . (resultToLints res <> lints,) - . embed - . resultToAdjusted - $ res - pure $ resultToAdjusted res - - --- | "invert" a linter's result, grouping lints by their messages -invertLintResult :: HasName ctxt => LintResult ctxt -> Map Hint [Text] -invertLintResult (LinterState (lints, ctxt)) = - fmap (sortNub . map getName) . fromListWith (<>) $ (, [ctxt]) <$> lintsToHints lints - -resultToDeps :: LintResult a -> [Dep] -resultToDeps (LinterState (lints,_)) = mapMaybe lintToDep lints - where lintToDep = \case - Depends dep -> Just dep - _ -> Nothing - -resultToOffers :: LintResult a -> [Text] -resultToOffers (LinterState a) = mapMaybe lintToOffer $ fst a - where lintToOffer = \case - Offers frag -> Just frag - _ -> Nothing - -resultToBadges :: LintResult a -> [Badge] -resultToBadges (LinterState a) = mapMaybe lintToBadge $ fst a - where lintToBadge (Badge badge) = Just badge - lintToBadge _ = Nothing - -resultToCWs :: LintResult a -> [Text] -resultToCWs (LinterState a) = fold $ mapMaybe lintToCW $ fst a - where lintToCW = \case (CW cw) -> Just cw; _ -> Nothing - -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] -resultToLints (LinterState res) = fst res - --- | extract the adjusted context from a lint result -resultToAdjusted :: LintResult a -> a -resultToAdjusted (LinterState res) = snd res - - - - --- | fundamental linter operations: add a lint of some severity -info = lint Info -suggest = lint Suggestion -warn = lint Warning -forbid = lint Forbidden -complain = lint Error - --- | add a dependency to the linter -dependsOn :: Dep -> LintWriter a -dependsOn dep = tell' $ Depends dep - --- | add an offer for an entrypoint to the linter -offersEntrypoint :: Text -> LintWriter a -offersEntrypoint text = tell' $ Offers text - --- | add an offer for a badge to the linter -offersBadge :: Badge -> LintWriter a -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 -askContext = lift $ asks (\(_,a,_) -> a) - --- | ask for the file depth within the repository tree of the current map. --- | This function brings in a lot more conceptual baggage than I'd like, but --- | it's needed to check if relative paths lie outside the repository -askFileDepth :: LintWriter' a Int -askFileDepth = lift $ asks (\(a,_,_) -> a) - --- | ask for a specific part of the linter's global config -lintConfig :: (LintConfig' -> a) -> LintWriter' ctxt a -lintConfig get = lift $ asks (\(_,_,config) -> get config) - - - - --- | tell, but for a singular lint. Leaves the context unchanged -tell' :: Lint -> LintWriter ctxt -tell' l = modify $ \(LinterState (lints, ctxt)) -> LinterState (l:lints, ctxt) - --- | small helper to tell a singlular proper lint -lint :: Level -> Text -> LintWriter a -lint level text = tell' $ hint level text - --- | adjusts the context. Gets a copy of the /current/ context, --- | i.e. one which might have already been changed by other adjustments -adjust :: (a -> a) -> LintWriter a -adjust f = modify $ LinterState . second f . fromLinterState diff --git a/lib/Paths.hs b/lib/Paths.hs deleted file mode 100644 index f4dc3ed..0000000 --- a/lib/Paths.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} - --- | Paths are horrible, so they have their own module now. --- I just hope you are running this on some kind of Unix -module Paths where - -import Universum -import qualified Universum.Unsafe as Unsafe - -import qualified Data.Text as T -import System.FilePath (splitPath) -import System.FilePath.Posix (()) -import Text.Regex.TDFA -import Util (PrettyPrint (prettyprint)) - - --- | a normalised path: a number of "upwards" steps, and --- a path without any . or .. in it. Also possibly a --- fragment, mostly for map links. -data RelPath = Path Int Text (Maybe Text) - deriving (Show, Eq, Ord, NFData, Generic) - - - -data PathResult = OkRelPath RelPath - | AbsolutePath - | NotAPath - | UnderscoreMapLink - | AtMapLink - | PathVarsDisallowed - --- | horrible regex parsing for filepaths that is hopefully kinda safe -parsePath :: Text -> PathResult -parsePath text = - if | T.isInfixOf "{{" text || T.isInfixOf "}}" text -> PathVarsDisallowed - | rest =~ ("^([^/]*[^\\./]/)*[^/]*[^\\./]$" :: Text) -> OkRelPath (Path up path fragment) - | "/_/" `T.isPrefixOf` text -> UnderscoreMapLink - | "/@/" `T.isPrefixOf` text -> AtMapLink - | "/" `T.isPrefixOf` text -> AbsolutePath - | otherwise -> NotAPath - where - (_, prefix, rest, _) = - text =~ ("^((\\.|\\.\\.)/)*" :: Text) :: (Text, Text, Text, [Text]) - -- how many steps upwards in the tree? - up = length . filter (".." ==) . T.splitOn "/" $ prefix - parts = T.splitOn "#" rest - -- `head` is unsafe, but splitOn will always produce lists with at least one element - path = Unsafe.head parts - fragment = case nonEmpty parts of - Nothing -> Nothing - Just p -> Just $ T.concat $ tail p - -instance PrettyPrint RelPath where - prettyprint (Path up rest frag) = ups <> rest <> fragment - where ups = T.concat $ replicate up "../" - fragment = maybe mempty ("#" <>) frag - --- | Normalises a path. --- --- It takes a `prefix`, and will "truncate" the .. operator --- at the end of the prefix, i.e. it will never return paths --- that lie (naïvely) outside of the prefix. -normalise :: FilePath -> RelPath -> FilePath -normalise prefix (Path 0 path _) = prefix toString path -normalise prefix (Path i path _) = - concat (take (length dirs - i) dirs) toString path - where dirs = splitPath prefix - -normaliseWithFrag :: FilePath -> RelPath -> FilePath -normaliseWithFrag prefix (Path i path frag) = - normalise prefix (Path (i+1) path frag) <> toString (maybe mempty ("#" <>) frag) - --- | does this path contain an old-style pattern for inter-repository --- links as was used at rc3 in 2020? -isOldStyle :: RelPath -> Bool -isOldStyle (Path _ text frag) = path =~ ("{<.+>*}" :: Text) - where path = case frag of - Just f -> text <> f - _ -> text - -getExtension :: RelPath -> Text -getExtension (Path _ text _) = maybe "" last (nonEmpty splitted) - where splitted = T.splitOn "." text diff --git a/lib/Properties.hs b/lib/Properties.hs deleted file mode 100644 index e72bfd0..0000000 --- a/lib/Properties.hs +++ /dev/null @@ -1,753 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - --- | Contains checks for custom ties of the map json -module Properties (checkMap, checkTileset, checkLayer) where - -import Universum hiding (intercalate, isPrefixOf) - -import Data.Text (intercalate, isPrefixOf) -import qualified Data.Text as T -import Data.Tiled (Layer (..), Object (..), Property (..), - PropertyValue (..), Tile (..), - Tiledmap (..), Tileset (..)) -import Data.Tiled.Abstract (HasData (..), HasName (..), - HasProperties (..), HasTypeName (..), - IsProperty (..), layerIsEmpty) -import qualified Data.Vector as V -import Util (mkProxy, naiveEscapeHTML, prettyprint) - -import Badges (Badge (Badge), - BadgeArea (BadgePoint, BadgeRect), - BadgeToken, parseToken) -import Data.List ((\\)) -import qualified Data.Set as S -import Data.Text.Metrics (damerauLevenshtein) -import GHC.TypeLits (KnownSymbol) -import LayerData (Collision, layerOverlaps) -import LintConfig (LintConfig (..)) -import LintWriter (LintWriter, adjust, askContext, - askFileDepth, complain, dependsOn, forbid, - lintConfig, offersBadge, offersCWs, - offersEntrypoint, offersJitsi, suggest, - warn, zoom) -import Paths (PathResult (..), RelPath (..), - getExtension, isOldStyle, parsePath) -import Types (Dep (Link, Local, LocalMap, MapLink)) -import Uris (SubstError (..), applySubsts) - - -knownMapProperties :: Vector Text -knownMapProperties = V.fromList - [ "mapName", "mapDescription", "mapCopyright", "mapLink", "script" - , "contentWarnings" ] - -knownTilesetProperties :: Vector Text -knownTilesetProperties = V.fromList - [ "tilesetCopyright", "collides"] - -knownObjectProperties :: Vector Text -knownObjectProperties = V.fromList - [ "name", "url", "getBadge", "soundRadius", "default", "persist", "openLayer" - , "closeLayer", "door", "bell", "openSound", "closeSound", "bellSound" - , "allowapi"] - -knownTileLayerProperites :: Vector Text -knownTileLayerProperites = V.fromList - [ "jitsiRoom", "jitsiTrigger", "jitsiTriggerMessage", "jitsiWidth" - , "playAudio", "audioLoop", "audioVolumne" - , "openWebsite", "openWebsiteTrigger", "openWebsiteTriggerMessage", "openTag" - , "exitUrl", "startLayer", "silent", "getBadge", "zone", "name", "doorVariable" - , "bindVariable", "bellVariable", "code", "openTriggerMessage" - , "closeTriggerMessage", "autoOpen", "autoClose", "bellButtonText", "bellPopup" - , "enterValue", "leaveValue" ] - --- | Checks an entire map for "general" lints. --- --- Note that it does /not/ check any tile layer/tileset properties; --- these are handled seperately in CheckMap, since these lints go --- into a different field of the output. -checkMap :: LintWriter Tiledmap -checkMap = do - tiledmap <- askContext - let layers = collectLayers tiledmap - let unlessLayer = unlessElement layers - - -- test custom map properties - mapM_ checkMapProperty (maybeToMonoid $ tiledmapProperties tiledmap) - - -- can't have these with the rest of layer/tileset lints since they're - -- not specific to any one of them - refuseDoubledNames layers - refuseDoubledNames (tiledmapTilesets tiledmap) - refuseDoubledNames (getProperties tiledmap) - - -- some layers should exist - unlessElementNamed layers "start" - $ complain "The map must have one layer named \"start\"." - unlessLayer (\l -> getName l == "floorLayer" && layerType l == "objectgroup") - $ complain "The map must have one layer named \"floorLayer\" of type \"objectgroup\"." - unlessLayer (`containsProperty` "exitUrl") - $ complain "The map must contain at least one layer with the property \"exitUrl\" set." - - -- reject maps not suitable for workadventure - unless (tiledmapOrientation tiledmap == "orthogonal") - $ complain "The map's orientation must be set to \"orthogonal\"." - unless (tiledmapTileheight tiledmap == 32 && tiledmapTilewidth tiledmap == 32) - $ complain "The map's tile size must be 32 by 32 pixels." - - unlessHasProperty "mapCopyright" - $ suggest "document the map's copyright via the \"mapCopyright\" property." - - unlessHasProperty "contentWarnings" - $ suggest "set content warnings for your map via the \"contentWarnings\" property." - - -- TODO: this doesn't catch collisions with the default start layer! - whenLayerCollisions layers (\(Property name _) -> name == "exitUrl" || name == "startLayer") - $ \cols -> warn $ "collisions between entry and / or exit layers: " <> prettyprint cols - - let missingMetaInfo = - ["mapName","mapDescription","mapLink"] - \\ map getName (getProperties tiledmap) - - unless (null missingMetaInfo) - $ suggest $ "consider adding meta information to your map using the " - <> prettyprint missingMetaInfo <> " properties." - - where - -- recursively find all layers (to deal with nested group layers) - collectLayers :: Tiledmap -> V.Vector Layer - collectLayers tiledmap = tiledmapLayers tiledmap <> - V.fromList (concatMap groupmembers (tiledmapLayers tiledmap)) - where groupmembers :: Layer -> [Layer] - groupmembers layer = concatMap groupmembers layers <> layers - where layers = fromMaybe [] $ layerLayers layer - --- | Checks a single property of a map. -checkMapProperty :: Property -> LintWriter Tiledmap -checkMapProperty p@(Property name _) = case name of - "mapName" -> naiveEscapeProperty p - "mapDescription" -> naiveEscapeProperty p - "mapCopyright" -> naiveEscapeProperty p - "mapLink" -> pure () - "contentWarnings" -> - unwrapString p $ \str -> do - offersCWs (T.splitOn "," str) - -- usually the linter will complain if names aren't in their - -- "canonical" form, but allowing that here so that multiple - -- scripts can be used by one map - _ | T.toLower name == "script" -> - unwrapURI (Proxy @"script") p - (dependsOn . Link) - (const $ forbid "scripts loaded from local files are disallowed") - | name `elem` ["jitsiRoom", "playAudio", "openWebsite" - , "url", "exitUrl", "silent", "getBadge"] - -> complain $ "property " <> name - <> " should be set on layers, not the map directly" - | otherwise - -> warnUnknown p knownMapProperties - - --- | check an embedded tileset. --- --- Important to collect dependency files -checkTileset :: LintWriter Tileset -checkTileset = do - tileset <- askContext - case tilesetImage tileset of - Just str -> unwrapPath str (dependsOn . Local) - Nothing -> complain "Tileset does not refer to an image." - - refuseDoubledNames (getProperties tileset) - - -- reject tilesets unsuitable for workadventure - unless (tilesetTilewidth tileset == 32 && tilesetTileheight tileset == 32) - $ complain "Tilesets must have tile size 32x32." - - when (tilesetImageheight tileset > 4096 || tilesetImagewidth tileset > 4096) - $ warn "Tilesets should not be larger than 4096x4096 pixels in total." - - when (isJust (tilesetSource tileset)) - $ complain "Tilesets must be embedded and cannot be loaded from external files." - - unlessHasProperty "tilesetCopyright" - $ forbid "property \"tilesetCopyright\" for tilesets must be set." - - when (isJust (tilesetFileName tileset)) - $ complain "The \"filename\" property on tilesets was removed; use \"image\" instead (and perhaps a newer version of the Tiled Editor)." - - -- check properties of individual tiles - tiles' <- forM (tilesetTiles tileset) $ mapM $ \tile -> do - mapM_ (checkTileProperty tile) (getProperties tile) - zoom (const tileset) (const tile) $ mapM_ (checkTileThing True) (getProperties tile) - - adjust (\t -> t { tilesetTiles = tiles' }) - - -- check individual tileset properties - mapM_ checkTilesetProperty (maybeToMonoid $ tilesetProperties tileset) - - case tilesetTiles tileset of - Nothing -> pure () - Just tiles -> ifDoubledThings tileId - -- can't set properties on the same tile twice - (\tile -> complain $ "cannot set properties on the \ - \tile with the id" <> show (tileId tile) <> "twice.") - tiles - - where - checkTilesetProperty :: Property -> LintWriter Tileset - checkTilesetProperty p@(Property name _value) = case name of - "tilesetCopyright" -> naiveEscapeProperty p - "collides" -> warn "property \"collides\" should be set on individual tiles, not the tileset" - _ -> warn $ "unknown tileset property " <> prettyprint name - - checkTileProperty :: Tile -> Property -> LintWriter Tileset - checkTileProperty tile p@(Property name _) = - case name of - "collides" -> isBool p - -- named tiles are needed for scripting and do not hurt otherwise - "name" -> isString p - "tilesetCopyright" -> warn "the \"tilesetCopyright\" property should be set on the entire tileset, \ - \not an individual tile." - _ -> warnUnknown' ("unknown tile property " - <> prettyprint name <> " in tile with global id " - <> show (tileId tile)) p knownTilesetProperties - - --- | collect lints on a single map layer -checkLayer :: LintWriter Layer -checkLayer = do - layer <- askContext - - refuseDoubledNames (getProperties layer) - - when (isJust (layerImage layer)) - $ complain "imagelayer are not supported." - - case layerType layer of - "tilelayer" -> mapM_ (checkTileThing False) (getProperties layer) - "group" -> pure () - "objectgroup" -> do - - -- check object properties - objs <- forM (layerObjects layer) $ mapM $ \object -> do - -- this is a confusing constant zoom ... - zoom (const layer) (const object) $ mapM_ checkObjectProperty (getProperties object) - adjust (\l -> l { layerObjects = objs }) - - -- all objects which don't define badges - let publicObjects = map (V.filter (not . (`containsProperty` "getBadge"))) objs - - -- remove badges from output - adjust $ \l -> l { layerObjects = publicObjects - , layerProperties = Nothing } - - -- check layer properties - forM_ (getProperties layer) checkObjectGroupProperty - - unless (layerName layer == "floorLayer") $ - when (isNothing (layerObjects layer) || layerObjects layer == Just mempty) $ - warn "objectgroup layer (which aren't the floorLayer) \ - \are useless if they are empty." - - ty -> complain $ "unsupported layer type " <> prettyprint ty <> "." - - if layerType layer == "group" - then when (isNothing (layerLayers layer)) - $ warn "Empty group layers are pointless." - else when (isJust (layerLayers layer)) - $ complain "Layer is not of type \"group\", but has sublayers." - -checkObjectProperty :: Property -> LintWriter Object -checkObjectProperty p@(Property name _) = do - obj <- askContext - case name of - "url" -> do - unwrapURI (Proxy @"website") p - (dependsOn . Link) - (const $ forbid "using \"url\" to open local html files is disallowed.") - unless (objectType obj == "website") - $ complain "\"url\" can only be set for objects of type \"website\"" - "getBadge" -> do - when (1 /= length (getProperties obj)) - $ warn "Objects with the property \"getBadge\" set are removed at runtime, \ - \and any other properties set on them will be gone." - unwrapString p $ \str -> - unwrapBadgeToken str $ \token -> do - case obj of - ObjectPolygon {} -> complain "polygons are not supported." - ObjectPolyline {} -> complain "polylines are not supported." - ObjectText {} -> complain "cannot use texts to define badge areas." - ObjectRectangle {..} -> - if objectEllipse == Just True - then complain "ellipses are not supported." - else offersBadge - $ Badge token $ case (objectWidth, objectHeight) of - (Just w, Just h) | w /= 0 && h /= 0 -> - BadgeRect objectX objectY w h - _ -> BadgePoint objectX objectY - "soundRadius" -> do - isIntInRange 0 maxBound p - unless (containsProperty obj "door" || containsProperty obj "bell") - $ complain "property \"soundRadius\" can only be set on objects with \ - \either property \"bell\" or \"door\" also set." - - _ | name `elem` [ "default", "persist" ] -> - suggestPropertyName' "door" - -- extended API for doors and bells - | name `elem` [ "openLayer", "closeLayer" ] -> do - isString p - suggestPropertyName' "door" - -- extended API for doors and bells - | name `elem` ["door", "bell"] -> do - isBool p - unless (objectType obj == "variable") $ - complain $ "the "<>prettyprint name<>" property should only be set \ - \on objects of type \"variable\"" - when (isNothing (objectName obj) || objectName obj == Just mempty) $ - complain $ "Objects with the property "<>prettyprint name<>" set must \ - \be named." - | name `elem` [ "openSound", "closeSound", "bellSound", "loadSound" ] -> do - isString p - unwrapURI (Proxy @"audio") p - (dependsOn . Link) - (dependsOn . Local) - case name of - "bellSound" -> - suggestPropertyName' "bell" - "closeSound" | containsProperty obj "openSound" -> - suggestPropertyName' "door" - _ -> do - suggestPropertyName' "door" - suggestPropertyName "soundRadius" - "set \"soundRadius\" to limit the door sound to a certain area." - | T.toLower name == "allowapi" - -> forbidProperty name - | otherwise -> - warnUnknown p knownObjectProperties - --- | Checks a single (custom) property of an objectgroup layer -checkObjectGroupProperty :: Property -> LintWriter Layer -checkObjectGroupProperty (Property name _) = case name of - "getBadge" -> warn "the property \"getBadge\" must be set on individual objects, \ - \not the object layer." - _ -> warn $ "unknown property " <> prettyprint name <> " for objectgroup layers" - - - --- | Checks a single (custom) property. Since almost all properties --- can be set on tile layer AND on tilesets, this function aims to --- be generic over both — the only difference is that tilesets can't --- have exits, which is specified by the sole boolean argument -checkTileThing - :: (HasProperties a, HasName a, HasData a) - => Bool -> Property -> LintWriter a -checkTileThing removeExits p@(Property name _value) = case name of - "jitsiRoom" -> do - uselessEmptyLayer - -- members of an assembly should automatically get - -- admin rights in jitsi (prepending "assembly-" here - -- to avoid namespace clashes with other admins) - lintConfig configAssemblyTag - >>= setProperty "jitsiRoomAdminTag" - . ("assembly-" <>) - unwrapString p $ \jitsiRoom -> do - suggestProperty $ Property "jitsiTrigger" "onaction" - - -- prevents namespace clashes for jitsi room names - 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" - $ suggest "set \"jitsiTriggerMessage\" to a custom message to overwrite \ - \the default \"press SPACE to enter in jitsi meet room\"." - requireProperty "jitsiRoom" - "jitsiTriggerMessage" -> do - isString p - requireProperty "jitsiTrigger" - "jitsiWidth" -> - isIntInRange 0 100 p - "playAudio" -> do - uselessEmptyLayer - unwrapURI (Proxy @"audio") p - (dependsOn . Link) - (dependsOn . Local) - "audioLoop" -> do - isBool p - requireProperty "playAudio" - "playAudioLoop" -> - deprecatedUseInstead "audioLoop" - "audioVolume" -> do - isOrdInRange unwrapFloat 0 1 p - requireProperty "playAudio" - "openWebsiteTrigger" -> do - isString p - requireOneOf ["openWebsite", "openTab"] - unlessHasProperty "openWebsiteTriggerMessage" - $ suggest "set \"openWebsiteTriggerMessage\" to a custom message to \ - \overwrite the default \"press SPACE to open Website\"." - "openWebsiteTriggerMessage" -> do - isString p - requireProperty "openWebsiteTrigger" - "url" -> complain "the property \"url\" defining embedded iframes must be \ - \set on an object in an objectgroup layer." - "exitUrl" -> if not removeExits - then do - forbidEmptyLayer - unwrapURI (Proxy @"map") p - (\link -> do - assemblyslug <- lintConfig configAssemblyTag - eventslug <- lintConfig configEventSlug - case T.stripPrefix ("/@/"<>eventslug<>"/"<>assemblyslug<>"/") link of - Nothing -> do - dependsOn (MapLink link) - setProperty "exitUrl" link - Just path -> case parsePath path of - OkRelPath (Path _ p frag) -> do - up <- askFileDepth - dependsOn (LocalMap (Path up p frag)) - setProperty "exitUrl" path - warn "You should use relative links to your own assembly instead \ - \of world://-style links (I've tried to adjust them \ - \automatically for now)." - _ -> complain "There's a path I don't understand here. Perhaps try \ - \asking a human?" - ) - ( \path -> - let ext = getExtension path in - if | isOldStyle path -> do - eventslug <- lintConfig configEventSlug - complain $ - "Old-Style inter-repository links (using {}) \ - \cannot be used at "<>eventslug<>"; please use world:// \ - \instead (see the howto)." - | ext == "tmx" -> - complain "Cannot use .tmx map format; use Tiled's json export instead." - | ext /= "json" -> - complain "All exit links must link to .json files." - | otherwise -> dependsOn . LocalMap $ path - ) - else do - warn "exitUrls in Tilesets are not unsupported; if you want to \ - \add an exit, please use a tile layer instead." - "exitSceneUrl" -> - deprecatedUseInstead "exitUrl" - "exitInstance" -> - deprecatedUseInstead "exitUrl" - "startLayer" -> do - forbidEmptyLayer - layer <- askContext - unwrapBool p $ \case - True -> offersEntrypoint $ getName layer - False -> warn "property \"startLayer\" is useless if set to false." - "silent" -> do - isBool p - uselessEmptyLayer - "getBadge" -> complain "\"getBadge\" must be set on an \"objectgroup\" \ - \ layer; it does not work on tile layers." - - -- extended API stuff - "zone" -> do - isString p - uselessEmptyLayer - -- name on tile layer unsupported - "name" -> isUnsupported - _ | name `elem` [ "doorVariable", "bindVariable", "bellVariable" ] - -> do { isString p; requireProperty "zone" } - | name `elem` [ "code", "openTriggerMessage", "closeTriggerMessage"] - -> do { isString p; requireProperty "doorVariable" } - | name `elem` [ "autoOpen", "autoClose"] - -> do { isBool p; requireProperty "doorVariable" } - | name `elem` [ "bellButtonText", "bellPopup" ] - -> do { isString p; requireProperty "bellVariable" } - | name `elem` [ "enterValue", "leaveValue" ] - -> do { isString p; requireProperty "bindVariable" } - | T.toLower name `elem` [ "jitsiurl", "jitsiconfig", "jitsiclientconfig" - , "jitsiroomadmintag", "jitsiinterfaceconfig" - , "openwebsitepolicy", "allowapi" ] - -> forbidProperty name - | name `elem` [ "openWebsite", "openTab" ] -> do - uselessEmptyLayer - suggestProperty $ Property "openWebsiteTrigger" "onaction" - - properties <- askContext <&> getProperties - let isScript = any (\(Property name _) -> - T.toLower name == "openwebsiteallowapi") - properties - if isScript - then unwrapURI (Proxy @"script") p - (dependsOn . Link) - (const $ forbid "accessing local html files is disallowed") - else unwrapURI (Proxy @"website") p - (dependsOn . Link) - (const $ forbid "accessing local html files is disallowed.") - | otherwise -> - when (not removeExits || name `notElem` [ "collides", "name", "tilesetCopyright" ]) $ do - warnUnknown p knownTileLayerProperites - where - requireProperty req = propertyRequiredBy req name - requireOneOf names = do - context <- askContext - unless (any (containsProperty context) names) - $ complain $ "property " <> prettyprint name <> " requires one of " - <> prettyprint names - - isUnsupported = warn $ "property " <> name <> " is not (yet) supported by walint." - deprecatedUseInstead instead = - warn $ "property \"" <> name <> "\" is deprecated. Use \"" <> instead <> "\" instead." - - -- | this property can only be used on a layer that contains - -- | at least one tile - forbidEmptyLayer = when removeExits $ do - layer <- askContext - when (layerIsEmpty layer) - $ complain ("property " <> prettyprint name <> " should not be set on an empty layer.") - - -- | this layer is allowed, but also useless on a layer that contains no tiles - uselessEmptyLayer = when removeExits $ do - layer <- askContext - when (layerIsEmpty layer) - $ warn ("property " <> prettyprint name <> " set on an empty layer is useless.") - - --- | refuse doubled names in everything that's somehow a collection of names -refuseDoubledNames - :: (Container t, HasName (Element t), HasTypeName (Element t)) - => t - -> LintWriter b -refuseDoubledNames = ifDoubledThings getName - (\thing -> complain $ "cannot use " <> typeName (mkProxy thing) <> " name " - <> getName thing <> " multiple times.") - --- | do `ifDouble` if any element of `things` occurs more than once under --- the function `f` -ifDoubledThings - :: (Eq a, Ord a, Container t) - => (Element t -> a) - -> (Element t -> LintWriter b) - -> t - -> LintWriter b -ifDoubledThings f ifDouble things = foldr folding base things (mempty, mempty) - where - folding thing cont (seen, twice) - | f thing `elem` seen && f thing `notElem` twice = do - ifDouble thing - cont (seen, S.insert (f thing) twice) - | otherwise = - cont (S.insert (f thing) seen, twice) - base _ = pure () - --- | we don't know this property; give suggestions for ones with similar names -warnUnknown' :: Text -> Property -> Vector Text -> LintWriter a -warnUnknown' msg (Property name _) knowns = - if snd minDist < 4 - then warn (msg <> ", perhaps you meant " <> prettyprint (fst minDist) <> "?") - else warn msg - where dists = V.map (\n -> (n, damerauLevenshtein name n)) knowns - minDist = V.minimumBy (\(_,a) (_,b) -> compare a b) dists - -warnUnknown :: Property -> Vector Text -> LintWriter a -warnUnknown p@(Property name _) = - warnUnknown' ("unknown property " <> prettyprint name) p - ----- General functions ---- - -unlessElement - :: Container f - => f - -> (Element f -> Bool) - -> LintWriter b - -> LintWriter b -unlessElement things op = unless (any op things) - -unlessElementNamed :: (HasName (Element f), Container f) - => f -> Text -> LintWriter b -> LintWriter b -unlessElementNamed things name = - unlessElement things ((==) name . getName) - -unlessHasProperty :: HasProperties a => Text -> LintWriter a -> LintWriter a -unlessHasProperty name linter = - askContext >>= \ctxt -> - unlessElementNamed (getProperties ctxt) name linter - --- | does this layer have the given property? -containsProperty :: HasProperties a => a -> Text -> Bool -containsProperty thing name = any - (\(Property name' _) -> name' == name) (getProperties thing) - --- | should the layers fulfilling the given predicate collide, then perform andthen. -whenLayerCollisions - :: V.Vector Layer - -> (Property -> Bool) - -> (Set Collision -> LintWriter a) - -> LintWriter a -whenLayerCollisions layers f andthen = do - let collisions = layerOverlaps . V.filter (any f . getProperties) $ layers - unless (null collisions) - $ andthen collisions - ------ Functions with concrete lint messages ----- - --- | this property is forbidden and should not be used -forbidProperty :: HasProperties a => Text -> LintWriter a -forbidProperty name = - forbid $ "property " <> prettyprint name <> " is disallowed." - -propertyRequiredBy :: HasProperties a => Text -> Text -> LintWriter a -propertyRequiredBy req by = - unlessHasProperty req - $ complain $ "property " <> prettyprint req <> - " is required by property " <> prettyprint by <> "." - --- | suggest some value for another property if that property does not --- also already exist -suggestProperty :: HasProperties a => Property -> LintWriter a -suggestProperty p@(Property name value) = - suggestProperty' p $ "add property " <> prettyprint name <> " to \"" <> prettyprint value<>"\"." - -suggestProperty' :: HasProperties a => Property -> Text -> LintWriter a -suggestProperty' (Property name _) msg = - unlessHasProperty name (suggest msg) - -suggestPropertyName :: HasProperties a => Text -> Text -> LintWriter a -suggestPropertyName name msg = - unlessHasProperty name (suggest msg) - -suggestPropertyName' :: HasProperties a => Text -> LintWriter a -suggestPropertyName' name = suggestPropertyName name - $ "consider setting property " <> prettyprint name <> "." - ----- Functions for adjusting the context ----- - - --- | set a property, overwriting whatever value it had previously -setProperty :: (IsProperty prop, HasProperties ctxt) - => Text -> prop -> LintWriter ctxt -setProperty name value = adjust $ \ctxt -> - flip adjustProperties ctxt - $ \ps -> Just $ Property name (asProperty value) : filter sameName ps - where sameName (Property name' _) = name /= name' - -naiveEscapeProperty :: HasProperties a => Property -> LintWriter a -naiveEscapeProperty prop@(Property name _) = - unwrapString prop (setProperty name . naiveEscapeHTML) - ----- "unwrappers" checking that a property has some type, then do something ---- - --- | asserts that this property is a string, and unwraps it -unwrapString :: Property -> (Text -> LintWriter a) -> LintWriter a -unwrapString (Property name value) f = case value of - StrProp str -> f str - _ -> complain $ "type error: property " - <> prettyprint name <> " should be of type string." - - --- | asserts that this property is a boolean, and unwraps it -unwrapBool :: Property -> (Bool -> LintWriter a) -> LintWriter a -unwrapBool (Property name value) f = case value of - BoolProp b -> f b - _ -> complain $ "type error: property " <> prettyprint name - <> " should be of type bool." - -unwrapInt :: Property -> (Int -> LintWriter a) -> LintWriter a -unwrapInt (Property name value) f = case value of - IntProp float -> f float - _ -> complain $ "type error: property " <> prettyprint name - <> " should be of type int." - -unwrapFloat :: Property -> (Float -> LintWriter a) -> LintWriter a -unwrapFloat (Property name value) f = case value of - FloatProp float -> f float - _ -> complain $ "type error: property " <> prettyprint name - <> " should be of type float." - -unwrapPath :: Text -> (RelPath -> LintWriter a) -> LintWriter a -unwrapPath str f = case parsePath str of - OkRelPath p@(Path up _ _) -> do - depth <- askFileDepth - if up <= depth - then f p - else complain $ "cannot acess paths \"" <> str <> "\" which is outside your repository." - NotAPath -> complain $ "path \"" <> str <> "\" is invalid." - AbsolutePath -> forbid "absolute paths are disallowed. Use world:// instead." - UnderscoreMapLink -> forbid "map links using /_/ are disallowed. Use world:// instead." - AtMapLink -> forbid "map links using /@/ are disallowed. Use world:// instead." - PathVarsDisallowed -> forbid "extended API variables are not allowed in asset paths." - -unwrapBadgeToken :: Text -> (BadgeToken -> LintWriter a) -> LintWriter a -unwrapBadgeToken str f = case parseToken str of - Just a -> f a - Nothing -> complain "invalid badge token." - - --- | unwraps a link, giving two cases: --- - the link might be an (allowed) remote URI --- - the link might be relative to this map (i.e. just a filepath) -unwrapURI :: (KnownSymbol s, HasProperties a) - => Proxy s - -> Property - -> (Text -> LintWriter a) - -> (RelPath -> LintWriter a) - -> LintWriter a -unwrapURI sym p@(Property name _) f g = unwrapString p $ \link -> do - subst <- lintConfig configUriSchemas - case applySubsts sym subst link of - Right uri -> do - setProperty name uri - f uri - Left NotALink -> unwrapPath link g - Left err -> do - isLobby <- lintConfig configAssemblyTag <&> (== "lobby") - - (if isLobby then warn else complain) $ case err of - DomainIsBlocked domains -> link <> " is a blocked site; links in this \ - \context may link to " <> prettyprint domains - IsBlocked -> link <> " is blocked." - DomainDoesNotExist domain -> "The domain " <> domain <> " does not exist; \ - \please make sure it is spelled correctly." - SchemaDoesNotExist schema -> - "the URI schema " <> schema <> "// cannot be used." - WrongScope schema allowed -> - "the URI schema " <> schema <> "// cannot be used in property \ - \\"" <> name <> "\"; allowed " - <> (if length allowed == 1 then "is " else "are ") - <> intercalate ", " (map (<> "//") allowed) <> "." - VarsDisallowed -> "extended API links are disallowed in links" - - - --- | just asserts that this is a string -isString :: Property -> LintWriter a -isString = flip unwrapString (const $ pure ()) - --- | just asserts that this is a boolean -isBool :: Property -> LintWriter a -isBool = flip unwrapBool (const $ pure ()) - -isIntInRange :: Int -> Int -> Property -> LintWriter b -isIntInRange = isOrdInRange @Int unwrapInt - -isOrdInRange :: (Ord a, Show a) - => (Property -> (a -> LintWriter b) -> LintWriter b) - -> a - -> a - -> Property - -> LintWriter b -isOrdInRange unwrapa l r p@(Property name _) = unwrapa p $ \int -> - if l < int && int < r then pure () - else complain $ "Property " <> prettyprint name <> " should be between " - <> show l <> " and " <> show r<>"." diff --git a/lib/Types.hs b/lib/Types.hs deleted file mode 100644 index acba99d..0000000 --- a/lib/Types.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} - - --- | basic types for the linter to eat and produce --- The dark magic making thse useful is in LintWriter -module Types - ( Level(..) - , Lint(..) - , Dep(..) - , Hint(..) - , hint - , lintLevel - , lintsToHints - ) where - -import Universum - -import Control.Monad.Trans.Maybe () -import Data.Aeson (FromJSON, ToJSON (toJSON), - ToJSONKey, (.=)) - -import Badges (Badge) -import qualified Data.Aeson as A -import Paths (RelPath) -import Util (PrettyPrint (..)) -import WithCli (Argument, atomicArgumentsParser) -import WithCli.Pure (Argument (argumentType, parseArgument), - HasArguments (argumentsParser)) - - --- | Levels of errors and warnings, collectively called --- "Hints" until I can think of some better name -data Level = Info | Suggestion | Warning | Forbidden | Error | Fatal - deriving (Show, Generic, Ord, Eq, ToJSON, FromJSON, NFData) - -instance Argument Level where - argumentType Proxy = "Lint Level" - parseArgument arg = case arg of - "info" -> Just Info - "suggestion" -> Just Suggestion - "warning" -> Just Warning - "forbidden" -> Just Forbidden - "error" -> Just Error - "fatal" -> Just Fatal - _ -> Nothing - - -instance HasArguments Level where - argumentsParser = atomicArgumentsParser - --- | 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] | Jitsi Text - deriving (Ord, Eq, Generic) - -data Dep = Local RelPath | Link Text | MapLink Text | LocalMap RelPath - deriving (Generic, Ord, Eq, NFData) - -data Hint = Hint - { hintLevel :: Level - , hintMsg :: Text - } deriving (Generic, Ord, Eq, NFData) - --- | shorter constructor (called hint because (a) older name and --- (b) lint also exists and is monadic) -hint :: Level -> Text -> Lint -hint level msg = Lint Hint { hintLevel = level, hintMsg = msg } - --- | dependencies just have level Info -lintLevel :: Lint -> Level -lintLevel (Lint h) = hintLevel h -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 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 Hint where - toJSON (Hint l m) = A.object - [ "msg" .= m, "level" .= l ] - -instance ToJSON Dep where - toJSON = \case - Local text -> json "local" $ prettyprint text - Link text -> json "link" text - MapLink text -> json "mapservice" text - LocalMap text -> json "map" $ prettyprint text - where - json :: A.Value -> Text -> A.Value - json kind text = A.object [ "kind" .= kind, "dep" .= text ] - -instance PrettyPrint Dep where - prettyprint = \case - Local dep -> "[local dep: " <> prettyprint dep <> "]" - Link dep -> "[link dep: " <> dep <> "]" - MapLink dep -> "[map service dep: " <> dep <> "]" - LocalMap dep -> "[local map dep: " <> prettyprint dep <> "]" diff --git a/lib/Uris.hs b/lib/Uris.hs deleted file mode 100644 index 127b7f1..0000000 --- a/lib/Uris.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} - --- | Functions to deal with uris and custom uri schemes -module Uris where - -import Universum - -import Data.Aeson (FromJSON (..), Options (..), - SumEncoding (UntaggedValue), - defaultOptions, genericParseJSON) -import qualified Data.Map.Strict as M -import qualified Data.Text as T -import GHC.TypeLits (KnownSymbol, symbolVal) -import Network.URI (URI (..), URIAuth (..), parseURI, - uriToString) -import qualified Network.URI.Encode as URI - -data Substitution = - Prefixed { prefix :: Text, blocked :: [Text], allowed :: [Text], scope :: [String] } - | DomainSubstitution { substs :: Map Text Text, scope :: [String] } - | Allowed { scope :: [String], allowed :: [Text] } - | Unrestricted { scope :: [String] } - deriving (Generic, Show, NFData) - - -instance FromJSON Substitution where - parseJSON = genericParseJSON defaultOptions - { sumEncoding = UntaggedValue - , rejectUnknownFields = True - } - -type SchemaSet = Map Text [Substitution] - - --- | deconstruct a URI into a triple of [schema:]//[domain]/[tail...], --- and a normalised version of the same URI -parseUri :: Text -> Maybe (Text, Text, Text, Text) -parseUri raw = - case parseURI (toString (T.strip raw)) of - Nothing -> Nothing - Just uri@URI{..} -> case uriAuthority of - Nothing -> Nothing - Just URIAuth {..} -> Just - ( fromString uriScheme - , fromString $ uriUserInfo <> uriRegName <> uriPort - , fromString $ uriPath <> uriQuery <> uriFragment - , fromString $ uriToString id uri "" - ) - - -data SubstError = - SchemaDoesNotExist Text - | NotALink - | DomainDoesNotExist Text - | IsBlocked - | DomainIsBlocked [Text] - | VarsDisallowed - | WrongScope Text [Text] - -- ^ This link's schema exists, but cannot be used in this scope. - -- The second field contains a list of schemas that may be used instead. - deriving (Eq, Ord) -- errors are ordered so we can show more specific ones - - -applySubsts :: KnownSymbol s - => Proxy s -> SchemaSet -> Text -> Either SubstError Text -applySubsts s substs uri = do - when (T.isInfixOf "{{" uri || T.isInfixOf "}}" uri) - $ Left VarsDisallowed - parts@(schema, _, _, _) <- maybeToRight NotALink $ parseUri uri - - let rules = filter (elem thisScope . scope) . concat $ M.lookup schema substs - - case nonEmpty $ map (applySubst parts) rules of - Nothing -> Left (SchemaDoesNotExist schema) - Just result -> minimum result - where - thisScope = symbolVal s - applySubst (schema, domain, rest, uri) rule = do - - -- is this scope applicable? - unless (symbolVal s `elem` scope rule) - $ Left (WrongScope schema - $ map fst -- make list of available uri schemes - . filter (any (elem thisScope . scope) . snd) - $ toPairs substs) - - case rule of - DomainSubstitution table _ -> do - prefix <- case M.lookup domain table of - Nothing -> Left (DomainDoesNotExist (schema <> "//" <> domain)) - Just a -> Right a - pure (prefix <> rest) - Prefixed {..} - | domain `elem` blocked -> Left IsBlocked - | domain `elem` allowed -> Right uri - | otherwise -> Right (prefix <> URI.encodeText uri) - Allowed _ allowlist - | domain `elem` allowlist -> Right uri - | otherwise -> Left (DomainIsBlocked allowlist) - Unrestricted _ -> Right uri diff --git a/lib/Util.hs b/lib/Util.hs deleted file mode 100644 index ef35139..0000000 --- a/lib/Util.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - -module Util - ( mkProxy - , PrettyPrint(..) - , printPretty - , naiveEscapeHTML - , ellipsis - ) where - -import Universum - -import Data.Aeson as Aeson -import qualified Data.Set as S -import qualified Data.Text as T -import Data.Tiled (Layer, PropertyValue (..), Tileset (tilesetName), - layerName) - --- | helper function to create proxies -mkProxy :: a -> Proxy a -mkProxy = const Proxy - --- | a class to address all the string conversions necessary --- when using Show to much that just uses Text instead -class PrettyPrint a where - prettyprint :: a -> Text - --- | let's see if this is a good idea or makes type inference bite us -instance PrettyPrint Text where - prettyprint text = "\"" <> text <> "\"" - --- | same as show json, but without the "String" prefix for json strings -instance PrettyPrint Aeson.Value where - prettyprint = \case - Aeson.String s -> prettyprint s - v -> show v - -instance PrettyPrint t => PrettyPrint (Set t) where - prettyprint = prettyprint . S.toList - -instance PrettyPrint PropertyValue where - prettyprint = \case - StrProp str -> str - BoolProp bool -> if bool then "true" else "false" - IntProp int -> show int - FloatProp float -> show float - --- | here since Unit is sometimes used as dummy type -instance PrettyPrint () where - prettyprint _ = error "shouldn't pretty-print Unit" - -instance PrettyPrint Layer where - prettyprint = (<>) "layer " . layerName - -instance PrettyPrint Tileset where - prettyprint = (<>) "tileset " . tilesetName - -instance PrettyPrint a => PrettyPrint [a] where - prettyprint = T.intercalate ", " . fmap prettyprint - -printPretty :: PrettyPrint a => a -> IO () -printPretty = putStr . toString . prettyprint - - --- | for long lists which shouldn't be printed out in their entirety -ellipsis :: Int -> [Text] -> Text -ellipsis i texts - | i < l = prettyprint (take i texts) <> " ... (and " <> show (l-i) <> " more)" - | otherwise = prettyprint texts - where l = length texts - - - --- | naive escaping of html sequences, just to be sure that --- | workadventure won't mess things up again … -naiveEscapeHTML :: Text -> Text -naiveEscapeHTML = T.replace "<" "<" . T.replace ">" ">" diff --git a/lib/WriteRepo.hs b/lib/WriteRepo.hs deleted file mode 100644 index af4d4d7..0000000 --- a/lib/WriteRepo.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} - - --- | Module for writing an already linted map Repository back out again. -module WriteRepo (writeAdjustedRepository) where - -import Universum - -import CheckDir (DirResult (..), resultIsFatal) -import CheckMap (MapResult (..), ResultKind (..)) -import Data.Aeson (encodeFile) -import qualified Data.Set as S -import LintConfig (LintConfig (configDontCopyAssets), - LintConfig') -import Paths (normalise) -import System.Directory.Extra (copyFile, createDirectoryIfMissing, - doesDirectoryExist) -import System.Exit (ExitCode (..)) -import qualified System.FilePath as FP -import System.FilePath (takeDirectory) -import System.FilePath.Posix (()) -import Types (Dep (Local)) - - --- TODO: make this return a custom error type, not an exitcode -writeAdjustedRepository :: LintConfig' -> FilePath -> FilePath -> DirResult Full -> IO ExitCode -writeAdjustedRepository config inPath outPath result - | resultIsFatal config result = - pure (ExitFailure 1) - | otherwise = do - ifM (doesDirectoryExist outPath) (pure (ExitFailure 2)) $ do - createDirectoryIfMissing True outPath - - -- write out all maps - forM_ (toPairs $ dirresultMaps result) $ \(path,out) -> do - createDirectoryIfMissing True (takeDirectory (outPath path)) - encodeFile (outPath path) $ mapresultAdjusted out - - unless (configDontCopyAssets config) $ do - -- collect asset dependencies of maps - -- TODO: its kinda weird doing that here, tbh - let localdeps :: Set FilePath = - S.fromList . concatMap - (\(mappath,mapresult) -> - let mapdir = takeDirectory mappath in - mapMaybe (\case - Local path -> Just . normalise mapdir $ path - _ -> Nothing) - $ mapresultDepends mapresult) - . toPairs $ dirresultMaps result - - -- copy all assets - forM_ localdeps $ \path -> - let - assetPath = FP.normalise $ inPath path - newPath = FP.normalise $ outPath path - in do - createDirectoryIfMissing True (takeDirectory newPath) - copyFile assetPath newPath - - pure ExitSuccess diff --git a/nix/sources.json b/nix/sources.json deleted file mode 100644 index b0eafbe..0000000 --- a/nix/sources.json +++ /dev/null @@ -1,38 +0,0 @@ -{ - "haskellNix": { - "branch": "master", - "description": "Alternative Haskell Infrastructure for Nixpkgs", - "homepage": "https://input-output-hk.github.io/haskell.nix", - "owner": "input-output-hk", - "repo": "haskell.nix", - "rev": "659b73698e06c02cc0f3029383bd383c8acdbe98", - "sha256": "0i91iwa11sq0v82v0zl82npnb4qqfm71y7gn3giyaixslm73kspk", - "type": "tarball", - "url": "https://github.com/input-output-hk/haskell.nix/archive/659b73698e06c02cc0f3029383bd383c8acdbe98.tar.gz", - "url_template": "https://github.com///archive/.tar.gz" - }, - "niv": { - "branch": "master", - "description": "Easy dependency management for Nix projects", - "homepage": "https://github.com/nmattia/niv", - "owner": "nmattia", - "repo": "niv", - "rev": "65a61b147f307d24bfd0a5cd56ce7d7b7cc61d2e", - "sha256": "17mirpsx5wyw262fpsd6n6m47jcgw8k2bwcp1iwdnrlzy4dhcgqh", - "type": "tarball", - "url": "https://github.com/nmattia/niv/archive/65a61b147f307d24bfd0a5cd56ce7d7b7cc61d2e.tar.gz", - "url_template": "https://github.com///archive/.tar.gz" - }, - "nixpkgs": { - "branch": "21.05", - "description": "Nix Packages collection", - "homepage": "", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "7e9b0dff974c89e070da1ad85713ff3c20b0ca97", - "sha256": "1ckzhh24mgz6jd1xhfgx0i9mijk6xjqxwsshnvq789xsavrmsc36", - "type": "tarball", - "url": "https://github.com/NixOS/nixpkgs/archive/7e9b0dff974c89e070da1ad85713ff3c20b0ca97.tar.gz", - "url_template": "https://github.com///archive/.tar.gz" - } -} diff --git a/nix/sources.nix b/nix/sources.nix deleted file mode 100644 index 1938409..0000000 --- a/nix/sources.nix +++ /dev/null @@ -1,174 +0,0 @@ -# This file has been generated by Niv. - -let - - # - # The fetchers. fetch_ fetches specs of type . - # - - fetch_file = pkgs: name: spec: - let - name' = sanitizeName name + "-src"; - in - if spec.builtin or true then - builtins_fetchurl { inherit (spec) url sha256; name = name'; } - else - pkgs.fetchurl { inherit (spec) url sha256; name = name'; }; - - fetch_tarball = pkgs: name: spec: - let - name' = sanitizeName name + "-src"; - in - if spec.builtin or true then - builtins_fetchTarball { name = name'; inherit (spec) url sha256; } - else - pkgs.fetchzip { name = name'; inherit (spec) url sha256; }; - - fetch_git = name: spec: - let - ref = - if spec ? ref then spec.ref else - if spec ? branch then "refs/heads/${spec.branch}" else - if spec ? tag then "refs/tags/${spec.tag}" else - abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!"; - in - builtins.fetchGit { url = spec.repo; inherit (spec) rev; inherit ref; }; - - fetch_local = spec: spec.path; - - fetch_builtin-tarball = name: throw - ''[${name}] The niv type "builtin-tarball" is deprecated. You should instead use `builtin = true`. - $ niv modify ${name} -a type=tarball -a builtin=true''; - - fetch_builtin-url = name: throw - ''[${name}] The niv type "builtin-url" will soon be deprecated. You should instead use `builtin = true`. - $ niv modify ${name} -a type=file -a builtin=true''; - - # - # Various helpers - # - - # https://github.com/NixOS/nixpkgs/pull/83241/files#diff-c6f540a4f3bfa4b0e8b6bafd4cd54e8bR695 - sanitizeName = name: - ( - concatMapStrings (s: if builtins.isList s then "-" else s) - ( - builtins.split "[^[:alnum:]+._?=-]+" - ((x: builtins.elemAt (builtins.match "\\.*(.*)" x) 0) name) - ) - ); - - # The set of packages used when specs are fetched using non-builtins. - mkPkgs = sources: system: - let - sourcesNixpkgs = - import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) { inherit system; }; - hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath; - hasThisAsNixpkgsPath = == ./.; - in - if builtins.hasAttr "nixpkgs" sources - then sourcesNixpkgs - else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then - import {} - else - abort - '' - Please specify either (through -I or NIX_PATH=nixpkgs=...) or - add a package called "nixpkgs" to your sources.json. - ''; - - # The actual fetching function. - fetch = pkgs: name: spec: - - if ! builtins.hasAttr "type" spec then - abort "ERROR: niv spec ${name} does not have a 'type' attribute" - else if spec.type == "file" then fetch_file pkgs name spec - else if spec.type == "tarball" then fetch_tarball pkgs name spec - else if spec.type == "git" then fetch_git name spec - else if spec.type == "local" then fetch_local spec - else if spec.type == "builtin-tarball" then fetch_builtin-tarball name - else if spec.type == "builtin-url" then fetch_builtin-url name - else - abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}"; - - # If the environment variable NIV_OVERRIDE_${name} is set, then use - # the path directly as opposed to the fetched source. - replace = name: drv: - let - saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name; - ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}"; - in - if ersatz == "" then drv else - # this turns the string into an actual Nix path (for both absolute and - # relative paths) - if builtins.substring 0 1 ersatz == "/" then /. + ersatz else /. + builtins.getEnv "PWD" + "/${ersatz}"; - - # Ports of functions for older nix versions - - # a Nix version of mapAttrs if the built-in doesn't exist - mapAttrs = builtins.mapAttrs or ( - f: set: with builtins; - listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set)) - ); - - # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/lists.nix#L295 - range = first: last: if first > last then [] else builtins.genList (n: first + n) (last - first + 1); - - # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L257 - stringToCharacters = s: map (p: builtins.substring p 1 s) (range 0 (builtins.stringLength s - 1)); - - # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269 - stringAsChars = f: s: concatStrings (map f (stringToCharacters s)); - concatMapStrings = f: list: concatStrings (map f list); - concatStrings = builtins.concatStringsSep ""; - - # https://github.com/NixOS/nixpkgs/blob/8a9f58a375c401b96da862d969f66429def1d118/lib/attrsets.nix#L331 - optionalAttrs = cond: as: if cond then as else {}; - - # fetchTarball version that is compatible between all the versions of Nix - builtins_fetchTarball = { url, name ? null, sha256 }@attrs: - let - inherit (builtins) lessThan nixVersion fetchTarball; - in - if lessThan nixVersion "1.12" then - fetchTarball ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; })) - else - fetchTarball attrs; - - # fetchurl version that is compatible between all the versions of Nix - builtins_fetchurl = { url, name ? null, sha256 }@attrs: - let - inherit (builtins) lessThan nixVersion fetchurl; - in - if lessThan nixVersion "1.12" then - fetchurl ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; })) - else - fetchurl attrs; - - # Create the final "sources" from the config - mkSources = config: - mapAttrs ( - name: spec: - if builtins.hasAttr "outPath" spec - then abort - "The values in sources.json should not have an 'outPath' attribute" - else - spec // { outPath = replace name (fetch config.pkgs name spec); } - ) config.sources; - - # The "config" used by the fetchers - mkConfig = - { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null - , sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile) - , system ? builtins.currentSystem - , pkgs ? mkPkgs sources system - }: rec { - # The sources, i.e. the attribute set of spec name to spec - inherit sources; - - # The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers - inherit pkgs; - }; - -in -mkSources (mkConfig {}) // { __functor = _: settings: mkSources (mkConfig settings); } diff --git a/package.yaml b/package.yaml deleted file mode 100644 index ceefc73..0000000 --- a/package.yaml +++ /dev/null @@ -1,98 +0,0 @@ -name: walint -version: 0.1 -homepage: https://stuebinm.eu/git/walint -# TODO: license -author: stuebinm -maintainer: stuebinm@disroot.org -copyright: 2022 stuebinm -ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors -default-extensions: NoImplicitPrelude - -dependencies: - - base - - universum - - aeson - - bytestring - - text - -internal-libraries: - tiled: - source-dirs: 'tiled' - dependencies: - - vector - exposed-modules: - - Data.Tiled - - Data.Tiled.Abstract - - Data.Tiled.TH - -library: - source-dirs: 'lib' - dependencies: - - containers - - tiled - - text - - vector - - transformers - - either - - filepath - - getopt-generics - - regex-tdfa - - extra - - deepseq - - dotgen - - text-metrics - - uri-encode - - network-uri - exposed-modules: - - CheckDir - - CheckMap - - WriteRepo - - Util - - Types - - LintConfig - -executables: - walint: - main: Main.hs - source-dirs: 'src' - dependencies: - - walint - - getopt-generics - - aeson-pretty - - template-haskell - - process - walint-mapserver: - main: Main.hs - source-dirs: 'server' - ghc-options: -rtsopts -threaded - dependencies: - - walint - - containers - - base-compat - - time - - directory - - filepath - - warp - - wai - - wai-extra - - monad-logger - - lucid - - servant - - servant-server - - servant-client - - servant-lucid - - servant-websockets - - http-types - - http-client - - websockets - - process - - extra - - microlens-platform - - fmt - - tomland - - stm - - getopt-generics - - async - - cryptohash-sha1 - - uuid - - base64-bytestring diff --git a/server/Handlers.hs b/server/Handlers.hs index 8990f01..10a729c 100644 --- a/server/Handlers.hs +++ b/server/Handlers.hs @@ -1,7 +1,5 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} diff --git a/server/HtmlOrphans.hs b/server/HtmlOrphans.hs index e3887c6..a8a355c 100644 --- a/server/HtmlOrphans.hs +++ b/server/HtmlOrphans.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -7,8 +7,6 @@ -- so it's safe to never define it {-# OPTIONS_GHC -Wno-missing-methods #-} {-# OPTIONS_GHC -Wno-orphans #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -- | Module containing orphan instances of Lucid's ToHtml, used for rendering -- linter results as html @@ -236,7 +234,7 @@ instance ToHtml (Org True, RemoteRef, DirResult a) where where maxlevel = maximumLintLevel res - placeList :: (Monad m, ToHtml a) => [a] -> HtmlT m () + placeList :: (Monad m, ToHtml h) => [h] -> HtmlT m () placeList occurances = sequence_ . intersperse ", " $ occurances <&> \place -> code_ [class_ "small text-muted"] (toHtml place) diff --git a/server/Main.hs b/server/Main.hs index 0aafd65..6431b3f 100644 --- a/server/Main.hs +++ b/server/Main.hs @@ -1,13 +1,7 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} -- | simple server offering linting "as a service" diff --git a/server/Server.hs b/server/Server.hs index ac03a3b..059078b 100644 --- a/server/Server.hs +++ b/server/Server.hs @@ -1,24 +1,13 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Server ( loadConfig , Org(..) diff --git a/server/Worker.hs b/server/Worker.hs index ba0fb41..2aa74e0 100644 --- a/server/Worker.hs +++ b/server/Worker.hs @@ -1,10 +1,8 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-} module Worker (linterThread, Job(..)) where diff --git a/server/default.nix b/server/default.nix new file mode 100644 index 0000000..5826f0c --- /dev/null +++ b/server/default.nix @@ -0,0 +1,26 @@ +{ mkDerivation, aeson, async, base, base-compat, base64-bytestring +, bytestring, containers, cryptohash-sha1, directory, extra +, filepath, fmt, getopt-generics, http-client, http-types, lib +, lucid, microlens-platform, monad-logger, process, servant +, servant-client, servant-lucid, servant-server, servant-websockets +, stm, text, time, tomland, universum, uuid, wai, wai-extra, walint +, warp, websockets +}: +mkDerivation { + pname = "walint-server"; + version = "0.1"; + src = ./.; + isLibrary = false; + isExecutable = true; + executableHaskellDepends = [ + aeson 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 text time tomland universum + uuid wai wai-extra walint warp websockets + ]; + homepage = "https://stuebinm.eu/git/walint"; + license = "unknown"; + mainProgram = "walint-server"; +} diff --git a/server/server.cabal b/server/server.cabal new file mode 100644 index 0000000..5b563a6 --- /dev/null +++ b/server/server.cabal @@ -0,0 +1,55 @@ +cabal-version: 3.0 +name: walint-server +version: 0.1 +author: stuebinm +maintainer: stuebinm@disroot.org +copyright: 2023 stuebinm +homepage: https://stuebinm.eu/git/walint + +executable walint-server + main-is: Main.hs + other-modules: + Handlers + HtmlOrphans + Server + Worker + default-extensions: + NoImplicitPrelude + ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors -rtsopts -threaded + build-depends: + aeson + , 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 + , text + , time + , tomland + , universum + , uuid + , wai + , wai-extra + , walint + , warp + , websockets + default-language: GHC2021 diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 index 9628e1e..0000000 --- a/src/Main.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Main where - -import Universum - -import Data.Aeson (eitherDecodeFileStrict', encode) -import Data.Aeson.Encode.Pretty (encodePretty) -import Data.Aeson.KeyMap (coercionToHashMap) -import WithCli (HasArguments, withCli) - -import CheckDir (recursiveCheckDir, resultIsFatal) -import LintConfig (ConfigKind (..), LintConfig (..), - patchConfig) -import System.Exit (ExitCode (ExitFailure)) -import Types (Level (..)) -import Util (printPretty) -import qualified Version as V (version) -import WriteRepo (writeAdjustedRepository) - --- | the options this cli tool can take -data Options = Options - { repository :: Maybe String - -- ^ path to the repository containing maps to lint - , entrypoint :: Maybe String - -- ^ entrypoint in that repository - , json :: Bool - -- ^ emit json if --json was given - , lintlevel :: Maybe Level - -- ^ maximum lint level to print - , pretty :: Bool - -- ^ pretty-print the json to make it human-readable - , out :: Maybe String - -- ^ path to write the (possibly adjusted) maps to after linting - , configFile :: Maybe FilePath - -- ^ path to a config file. Currently required. - , config :: Maybe (LintConfig Patch) - -- ^ a "patch" for the configuration file - , version :: Bool - , dot :: Bool - } deriving (Show, Generic, HasArguments) - - -main :: IO () -main = withCli run - -run :: Options -> IO () -run Options { .. } = do - aesonWarning - - if version then - putStrLn V.version - else do - let repo = fromMaybe "." repository - let entry = fromMaybe "main.json" entrypoint - let level = fromMaybe Suggestion lintlevel - configFile' <- case configFile of - Nothing -> do - hPutStrLn stderr ("option --config-file=FILEPATH required" :: Text) - exitFailure - Just path -> pure path - - lintconfig <- eitherDecodeFileStrict' configFile' >>= \case - Left err -> error $ "config file invalid: " <> toText err - Right file -> pure (patchConfig file config) - - lints <- recursiveCheckDir lintconfig repo entry - - if json - then putText - $ decodeUtf8 (if pretty then encodePretty lints else encode lints) - else printPretty (level, lints) - - case out of - Nothing - | resultIsFatal lintconfig lints -> exitWith (ExitFailure 1) - | otherwise -> exitSuccess - Just outpath -> do - c <- writeAdjustedRepository lintconfig repo outpath lints - unless json $ - case c of - ExitFailure 1 -> - putTextLn "\nMap failed linting!" - ExitFailure 2 -> - putTextLn "\nOutpath already exists, not writing anything." - _ -> pass - exitWith c - - --- if Aesons's internal map and HashMap are the same type, then coercionToHashMap --- will contain a proof of that, and we can print a warning. Otherwise we're not --- using HashMaps in Aeson and everything is fine. --- --- cf. https://frasertweedale.github.io/blog-fp/posts/2021-10-12-aeson-hash-flooding-protection.html -aesonWarning :: IO () -aesonWarning = case coercionToHashMap of - Just _ -> hPutStrLn stderr - ("Warning: this program was compiled using an older version of the Aeson Library\n\ - \used for parsing JSON, which is susceptible to hash flooding attacks.\n\ - \n\ - \Recompiling with a newer version is recommended when handling untrusted inputs.\n\ - \n\ - \See https://cs-syd.eu/posts/2021-09-11-json-vulnerability for details." :: Text) - _ -> pass diff --git a/src/Version.hs b/src/Version.hs deleted file mode 100644 index 1748512..0000000 --- a/src/Version.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -module Version ( version ) where - -import Universum - -import qualified Language.Haskell.TH as TH -import System.Process (readProcess) - -version :: String -version = "walint generic 2022 (" <> - $(do - hash <- liftIO $ catchAny (readProcess "git" ["rev-parse", "HEAD"] "") - (\_ -> pure "[unknown]") - pure . TH.LitE . TH.StringL $ take 40 hash) ++ - ")" diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 index 56d9597..0000000 --- a/stack.yaml +++ /dev/null @@ -1,36 +0,0 @@ -resolver: lts-19.28 - -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# subdirs: -# - auto-update -# - wai -packages: -- . -# Dependency packages to be pulled from upstream that are not in the resolver. -# These entries can reference officially published versions as well as -# forks / in-progress versions pinned to a git hash. For example: -# -allow-newer: true -extra-deps: -- mustache-2.4.0@sha256:bd1cfbd027c04d8329877e95413d34dc357d4bee041dd8978cd6a23b114fbda1,3180 -- tomland-1.3.3.1@sha256:83a8fd26a97164100541f7b26aa40ffdc6f230b21e94cbb3eae1fb7093c4356e,8924 -- validation-selective-0.1.0.1@sha256:9a5aa8b801efc6a4ffb120e1b28e80c5f7d090043be56bba11222cd20c393044,3621 - -# use aeson with a non-hash-floodable implementation -flags: - aeson: - ordered-keymap: true - -nix: - enable: true - packages: - - zlib.dev - - zlib - - openssl - - git - - cacert diff --git a/stack.yaml.lock b/stack.yaml.lock deleted file mode 100644 index fb1ccd1..0000000 --- a/stack.yaml.lock +++ /dev/null @@ -1,33 +0,0 @@ -# This file was autogenerated by Stack. -# You should not edit this file by hand. -# For more information, please see the documentation at: -# https://docs.haskellstack.org/en/stable/lock_files - -packages: -- completed: - pantry-tree: - sha256: 44c4d43ecfe1fee11fb03ffd49b0580ed00eec5144067092801ef4256df77ef8 - size: 1182 - hackage: mustache-2.4.0@sha256:bd1cfbd027c04d8329877e95413d34dc357d4bee041dd8978cd6a23b114fbda1,3180 - original: - hackage: mustache-2.4.0@sha256:bd1cfbd027c04d8329877e95413d34dc357d4bee041dd8978cd6a23b114fbda1,3180 -- completed: - pantry-tree: - sha256: 0e3bdbd32955944c3ee9ff0f47dc765d25ab6be4a336c6d735eed8eb9bc8ce27 - size: 6430 - hackage: tomland-1.3.3.1@sha256:83a8fd26a97164100541f7b26aa40ffdc6f230b21e94cbb3eae1fb7093c4356e,8924 - original: - hackage: tomland-1.3.3.1@sha256:83a8fd26a97164100541f7b26aa40ffdc6f230b21e94cbb3eae1fb7093c4356e,8924 -- completed: - pantry-tree: - sha256: bf72fe4304690da4b5bc6e5218b0f90b5613e7d658f3ce31731816a423fcbca6 - size: 696 - hackage: validation-selective-0.1.0.1@sha256:9a5aa8b801efc6a4ffb120e1b28e80c5f7d090043be56bba11222cd20c393044,3621 - original: - hackage: validation-selective-0.1.0.1@sha256:9a5aa8b801efc6a4ffb120e1b28e80c5f7d090043be56bba11222cd20c393044,3621 -snapshots: -- completed: - sha256: 7f4393ad659c579944d12202cffb12d8e4b8114566b015f77bbc303a24cff934 - size: 619405 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/28.yaml - original: lts-19.28 diff --git a/static/Genos-VariableFont_wght.ttf b/static/Genos-VariableFont_wght.ttf deleted file mode 100644 index 0b96efd..0000000 Binary files a/static/Genos-VariableFont_wght.ttf and /dev/null differ diff --git a/static/Ubuntu-R.ttf b/static/Ubuntu-R.ttf deleted file mode 100644 index d748728..0000000 Binary files a/static/Ubuntu-R.ttf and /dev/null differ diff --git a/static/style.css b/static/style.css index b2e6db2..4d1a30e 100644 --- a/static/style.css +++ b/static/style.css @@ -1,23 +1,10 @@ - -@font-face { - font-family: Ubuntu; - src: url(/Ubuntu-R.ttf); -} - -@font-face { - font-family: Genos-divoc; - src: url(/Genos-VariableFont_wght.ttf); -} - body { - background-color: #57c0a2; - font-family: Ubuntu, sans-serif; + background-color: lightgray; } .btn { margin-left: 1em; - font-family: Ubuntu; } .main-content { @@ -26,8 +13,8 @@ body { margin: auto; margin-top: 10em; margin-bottom: 5em; - max-width: 50em; - background-color: #ffebd8; + max-width: 80em; + background-color: white; } a { @@ -72,10 +59,10 @@ ellipse { fill: black; } ellipse, polygon, path { - stroke: #a74db7; + stroke: lightgray; } polygon { - fill: #a74db7; + fill: lightgray; } #exitGraph { background-color: black; @@ -95,28 +82,7 @@ h2 { h3 { font-size: 2rem; } -h4{ - color: #9945c5; -} - -.badge-info { - background-color: #62c1a6; - color: black; -} -.badge-warning { - background-color: #fdbe4b; - color: black; -} - -.badge-danger { - background-color: #ea4a72; - color: black; -} - -.text-muted { - color: #9945c5 !important; -} @media (prefers-color-scheme: dark) { body { @@ -128,9 +94,9 @@ h4{ } .text-muted { - color: #fdbe4b !important; + color: lightgray !important; } - h4 { - color: #ffebd8; + code { + color: lightgray !important; } } diff --git a/tiled/Data/Tiled.hs b/tiled/Data/Tiled.hs index 9256375..99c5c9d 100644 --- a/tiled/Data/Tiled.hs +++ b/tiled/Data/Tiled.hs @@ -1,13 +1,9 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} diff --git a/tiled/default.nix b/tiled/default.nix new file mode 100644 index 0000000..c112497 --- /dev/null +++ b/tiled/default.nix @@ -0,0 +1,13 @@ +{ mkDerivation, aeson, base, bytestring, lib, text, universum +, vector +}: +mkDerivation { + pname = "tiled"; + version = "0.1"; + src = ./.; + libraryHaskellDepends = [ + aeson base bytestring text universum vector + ]; + homepage = "https://stuebinm.eu/git/walint"; + license = "unknown"; +} diff --git a/tiled/tiled.cabal b/tiled/tiled.cabal new file mode 100644 index 0000000..2864748 --- /dev/null +++ b/tiled/tiled.cabal @@ -0,0 +1,24 @@ +cabal-version: 3.0 +name: tiled +version: 0.1 +author: stuebinm +maintainer: stuebinm@disroot.org +copyright: 2022 stuebinm +homepage: https://stuebinm.eu/git/walint + +library + exposed-modules: + Data.Tiled + Data.Tiled.Abstract + Data.Tiled.TH + default-extensions: + NoImplicitPrelude + ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors + build-depends: + aeson + , base + , bytestring + , text + , universum + , vector + default-language: GHC2021 diff --git a/walint-cli/Main.hs b/walint-cli/Main.hs new file mode 100644 index 0000000..4bbc670 --- /dev/null +++ b/walint-cli/Main.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Main where + +import Universum + +import Data.Aeson (eitherDecodeFileStrict', encode) +import Data.Aeson.Encode.Pretty (encodePretty) +import Data.Aeson.KeyMap (coercionToHashMap) +import WithCli (HasArguments, withCli) + +import CheckDir (recursiveCheckDir, resultIsFatal) +import LintConfig (ConfigKind (..), LintConfig (..), + patchConfig) +import System.Exit (ExitCode (ExitFailure)) +import Types (Level (..)) +import Util (printPretty) +import qualified Version as V (version) +import WriteRepo (writeAdjustedRepository) + +-- | the options this cli tool can take +data Options = Options + { repository :: Maybe String + -- ^ path to the repository containing maps to lint + , entrypoint :: Maybe String + -- ^ entrypoint in that repository + , json :: Bool + -- ^ emit json if --json was given + , lintlevel :: Maybe Level + -- ^ maximum lint level to print + , pretty :: Bool + -- ^ pretty-print the json to make it human-readable + , out :: Maybe String + -- ^ path to write the (possibly adjusted) maps to after linting + , configFile :: Maybe FilePath + -- ^ path to a config file. Currently required. + , config :: Maybe (LintConfig Patch) + -- ^ a "patch" for the configuration file + , version :: Bool + , dot :: Bool + } deriving (Show, Generic, HasArguments) + + +main :: IO () +main = withCli run + +run :: Options -> IO () +run Options { .. } = do + aesonWarning + + if version then + putStrLn V.version + else do + let repo = fromMaybe "." repository + let entry = fromMaybe "main.json" entrypoint + let level = fromMaybe Suggestion lintlevel + configFile' <- case configFile of + Nothing -> do + hPutStrLn stderr ("option --config-file=FILEPATH required" :: Text) + exitFailure + Just path -> pure path + + lintconfig <- eitherDecodeFileStrict' configFile' >>= \case + Left err -> error $ "config file invalid: " <> toText err + Right file -> pure (patchConfig file config) + + lints <- recursiveCheckDir lintconfig repo entry + + if json + then putText + $ decodeUtf8 (if pretty then encodePretty lints else encode lints) + else printPretty (level, lints) + + case out of + Nothing + | resultIsFatal lintconfig lints -> exitWith (ExitFailure 1) + | otherwise -> exitSuccess + Just outpath -> do + c <- writeAdjustedRepository lintconfig repo outpath lints + unless json $ + case c of + ExitFailure 1 -> + putTextLn "\nMap failed linting!" + ExitFailure 2 -> + putTextLn "\nOutpath already exists, not writing anything." + _ -> pass + exitWith c + + +-- if Aesons's internal map and HashMap are the same type, then coercionToHashMap +-- will contain a proof of that, and we can print a warning. Otherwise we're not +-- using HashMaps in Aeson and everything is fine. +-- +-- cf. https://frasertweedale.github.io/blog-fp/posts/2021-10-12-aeson-hash-flooding-protection.html +aesonWarning :: IO () +aesonWarning = case coercionToHashMap of + Just _ -> hPutStrLn stderr + ("Warning: this program was compiled using an older version of the Aeson Library\n\ + \used for parsing JSON, which is susceptible to hash flooding attacks.\n\ + \n\ + \Recompiling with a newer version is recommended when handling untrusted inputs.\n\ + \n\ + \See https://cs-syd.eu/posts/2021-09-11-json-vulnerability for details." :: Text) + _ -> pass diff --git a/walint-cli/Version.hs b/walint-cli/Version.hs new file mode 100644 index 0000000..1748512 --- /dev/null +++ b/walint-cli/Version.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Version ( version ) where + +import Universum + +import qualified Language.Haskell.TH as TH +import System.Process (readProcess) + +version :: String +version = "walint generic 2022 (" <> + $(do + hash <- liftIO $ catchAny (readProcess "git" ["rev-parse", "HEAD"] "") + (\_ -> pure "[unknown]") + pure . TH.LitE . TH.StringL $ take 40 hash) ++ + ")" diff --git a/walint-cli/default.nix b/walint-cli/default.nix new file mode 100644 index 0000000..938bc4f --- /dev/null +++ b/walint-cli/default.nix @@ -0,0 +1,18 @@ +{ mkDerivation, aeson, aeson-pretty, base, bytestring +, getopt-generics, lib, process, template-haskell, text, universum +, walint +}: +mkDerivation { + pname = "walint-cli"; + version = "0.1"; + src = ./.; + isLibrary = false; + isExecutable = true; + executableHaskellDepends = [ + aeson aeson-pretty base bytestring getopt-generics process + template-haskell text universum walint + ]; + homepage = "https://stuebinm.eu/git/walint"; + license = "unknown"; + mainProgram = "walint"; +} diff --git a/walint-cli/walint-cli.cabal b/walint-cli/walint-cli.cabal new file mode 100644 index 0000000..6ca10bd --- /dev/null +++ b/walint-cli/walint-cli.cabal @@ -0,0 +1,27 @@ +cabal-version: 3.0 +name: walint-cli +version: 0.1 +author: stuebinm +maintainer: stuebinm@disroot.org +copyright: 2023 stuebinm +homepage: https://stuebinm.eu/git/walint + +executable walint + main-is: Main.hs + other-modules: + Version + default-extensions: + NoImplicitPrelude + ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors + build-depends: + aeson + , aeson-pretty + , base + , bytestring + , getopt-generics + , process + , template-haskell + , text + , universum + , walint + default-language: GHC2021 diff --git a/walint.cabal b/walint.cabal deleted file mode 100644 index 9cfb5ee..0000000 --- a/walint.cabal +++ /dev/null @@ -1,160 +0,0 @@ -cabal-version: 2.0 - --- This file has been generated from package.yaml by hpack version 0.34.7. --- --- see: https://github.com/sol/hpack - -name: walint -version: 0.1 -homepage: https://stuebinm.eu/git/walint -author: stuebinm -maintainer: stuebinm@disroot.org -copyright: 2022 stuebinm -build-type: Simple - -library - exposed-modules: - CheckDir - CheckMap - WriteRepo - Util - Types - LintConfig - other-modules: - Badges - Dirgraph - LayerData - LintWriter - Paths - Properties - Uris - Paths_walint - autogen-modules: - Paths_walint - hs-source-dirs: - lib - default-extensions: - NoImplicitPrelude - ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors - build-depends: - aeson - , base - , bytestring - , containers - , deepseq - , dotgen - , either - , extra - , filepath - , getopt-generics - , network-uri - , regex-tdfa - , text - , text-metrics - , tiled - , transformers - , universum - , uri-encode - , vector - default-language: Haskell2010 - -library tiled - exposed-modules: - Data.Tiled - Data.Tiled.Abstract - Data.Tiled.TH - other-modules: - Paths_walint - autogen-modules: - Paths_walint - hs-source-dirs: - tiled - default-extensions: - NoImplicitPrelude - ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors - build-depends: - aeson - , base - , bytestring - , text - , universum - , vector - default-language: Haskell2010 - -executable walint - main-is: Main.hs - other-modules: - Version - Paths_walint - autogen-modules: - Paths_walint - hs-source-dirs: - src - default-extensions: - NoImplicitPrelude - ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors - build-depends: - aeson - , aeson-pretty - , base - , bytestring - , getopt-generics - , process - , template-haskell - , text - , universum - , walint - default-language: Haskell2010 - -executable walint-mapserver - main-is: Main.hs - other-modules: - Handlers - HtmlOrphans - Server - Worker - Paths_walint - autogen-modules: - Paths_walint - hs-source-dirs: - server - default-extensions: - NoImplicitPrelude - ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors -rtsopts -threaded - build-depends: - aeson - , 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 - , text - , time - , tomland - , universum - , uuid - , wai - , wai-extra - , walint - , warp - , websockets - default-language: Haskell2010 diff --git a/walint/Badges.hs b/walint/Badges.hs new file mode 100644 index 0000000..9af34b3 --- /dev/null +++ b/walint/Badges.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | module defining Badge types and utility functions +module Badges where + +import Universum + +import Data.Aeson (Options (fieldLabelModifier, sumEncoding), + SumEncoding (UntaggedValue), ToJSON (toJSON), + defaultOptions, genericToJSON, (.=)) +import qualified Data.Aeson as A +import Data.Char (toLower) +import Text.Regex.TDFA ((=~)) + + +data BadgeArea = + BadgePoint + { areaX :: Double + , areaY :: Double + } + | BadgeRect + { areaX :: Double + , areaY :: Double + , areaWidth :: Double + , areaHeight :: Double + } + deriving (Ord, Eq, Generic, Show, NFData) + +newtype BadgeToken = BadgeToken Text + deriving newtype (Eq, Ord, Show, NFData) + +instance ToJSON BadgeArea where + toJSON = genericToJSON defaultOptions + { fieldLabelModifier = drop 4 . map toLower + , sumEncoding = UntaggedValue } + +instance ToJSON BadgeToken where + toJSON (BadgeToken text) = toJSON text + +parseToken :: Text -> Maybe BadgeToken +parseToken text = if text =~ ("^[a-zA-Z0-9]{50}$" :: Text) + then Just (BadgeToken text) + else Nothing + +data Badge = Badge BadgeToken BadgeArea + deriving (Ord, Eq, Generic, Show, NFData) + +instance ToJSON Badge where + toJSON (Badge token area) = A.object $ case area of + BadgePoint x y -> [ "x" .= x + , "y" .= y + , "token" .= token + , "type" .= A.String "point" + ] + BadgeRect {..} -> [ "x" .= areaX + , "y" .= areaY + , "token" .= token + , "width" .= areaWidth + , "height" .= areaHeight + , "type" .= A.String "rectangle" + ] diff --git a/walint/CheckDir.hs b/walint/CheckDir.hs new file mode 100644 index 0000000..c82c54b --- /dev/null +++ b/walint/CheckDir.hs @@ -0,0 +1,279 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Module that contains high-level checking for an entire directory +module CheckDir ( maximumLintLevel + , recursiveCheckDir + , DirResult (..) + , MissingAsset(..) + , MissingDep(..) + , resultIsFatal + ,shrinkDirResult) where + +import Universum hiding (Set) + +import CheckMap (MapResult (..), Optional, + ResultKind (..), loadAndLintMap, + shrinkMapResult) +import Control.Monad.Extra (mapMaybeM) +import Data.Aeson (ToJSON, (.=)) +import qualified Data.Aeson as A +import Data.List (partition) +import qualified Data.Map as M +import Data.Map.Strict (mapKeys, mapWithKey, (\\)) +import Data.Text (isInfixOf) +import qualified Data.Text as T +import Data.Tiled (Tiledmap) +import Dirgraph (graphToDot, invertGraph, resultToGraph, + takeSubGraph, unreachableFrom) +import LintConfig (LintConfig', configMaxLintLevel) +import Paths (normalise, normaliseWithFrag) +import System.Directory.Extra (doesFileExist) +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), + Level (..), hintLevel) +import Util (PrettyPrint (prettyprint), ellipsis) + + +-- based on the startling observation that Data.Map has lower complexity +-- for difference than Data.Set, but the same complexity for fromList +type Set a = Map a () +setFromList :: Ord a => [a] -> Set a +setFromList = M.fromList . flip zip (repeat ()) +listFromSet :: Set a -> [a] +listFromSet = map fst . M.toList + +-- | Result of linting an entire directory / repository +data DirResult (complete :: ResultKind) = DirResult + { dirresultMaps :: Map FilePath (MapResult complete) + -- ^ all maps of this respository, by (local) filepath + , dirresultDeps :: [MissingDep] + -- ^ all dependencies to things outside this repository + , dirresultMissingAssets :: [MissingAsset] + -- ^ entrypoints of maps which are referred to but missing + , dirresultGraph :: Text + } deriving (Generic) + +instance NFData (Optional a (Maybe Tiledmap)) => NFData (DirResult a) + + +data MissingDep = MissingDep + { depFatal :: Maybe Bool + , entrypoint :: Text + , neededBy :: [FilePath] + } deriving (Generic, ToJSON, NFData) + +-- | Missing assets are the same thing as missing dependencies, +-- but should not be confused (and also serialise differently +-- to json) +newtype MissingAsset = MissingAsset MissingDep + deriving (Generic, NFData) + + +-- | "shrink" the result by throwing the adjusted tiledmaps away +shrinkDirResult :: DirResult Full -> DirResult Shrunk +shrinkDirResult !res = + res { dirresultMaps = fmap shrinkMapResult (dirresultMaps res) } + +-- | given this config, should the result be considered to have failed? +resultIsFatal :: LintConfig' -> DirResult Full -> Bool +resultIsFatal config res = + not (null (dirresultMissingAssets res) || not (any (isJust . depFatal) (dirresultDeps res))) + || maximumLintLevel res > configMaxLintLevel config + +-- | maximum lint level that was observed anywhere in any map. +-- note that it really does go through all lints, so don't +-- call it too often +maximumLintLevel :: DirResult a -> Level +maximumLintLevel res + | not (null (dirresultMissingAssets res)) = Fatal + | otherwise = + (maybe Info maximum . nonEmpty) + . map hintLevel + . concatMap (\map -> keys (mapresultLayer map) + <> keys (mapresultTileset map) + <> mapresultGeneral map + ) + . elems + . dirresultMaps + $ res + + + +instance ToJSON (DirResult a) where + toJSON res = A.object [ + "result" .= A.object + [ "missingDeps" .= dirresultDeps res + , "missingAssets" .= dirresultMissingAssets res + -- some repos have auto-generated maps which are basically all the + -- same; aggregate those to reduce output size + , "mapLints" .= (M.fromList + . fmap (first (ellipsis 6)) + . foldr aggregateSameResults [] + . M.toList + $ dirresultMaps res) + , "exitGraph" .= dirresultGraph res + ] + , "severity" .= maximumLintLevel res + , "mapInfo" .= fmap (\tm -> A.object [ "badges" .= mapresultBadges tm ]) + (dirresultMaps res) + ] + where + aggregateSameResults (path,res) acc = + case partition (\(_,res') -> res == res') acc of + ([],_) -> ([toText path], res):acc + ((paths,_):_,acc') -> (toText path:paths, res) : acc' + +instance ToJSON MissingAsset where + toJSON (MissingAsset md) = A.object + [ "asset" .= entrypoint md + , "neededBy" .= neededBy md + ] + + +instance PrettyPrint (Level, DirResult a) where + prettyprint (level, res) = prettyMapLints <> prettyMissingDeps + where + prettyMissingDeps = if not (null (dirresultDeps res)) + then "\nDependency Errors:\n" <> foldMap prettyprint (dirresultDeps res) + else "" + prettyMapLints = T.concat + (map prettyLint $ M.toList $ dirresultMaps res) + prettyLint :: (FilePath, MapResult a) -> Text + prettyLint (p, lint) = + "\nin " <> toText p <> ":\n" <> prettyprint (level, lint) + +instance PrettyPrint MissingDep where + prettyprint (MissingDep _ f n) = + " - " <> f <> " does not exist, but is required by " + <> prettyDependents <> "\n" + where + prettyDependents = + T.intercalate "," $ map toText n + + +-- | check an entire repository +recursiveCheckDir + :: LintConfig' + -> FilePath + -- ^ the repository's prefix (i.e. path to its directory) + -> FilePath + -- ^ the repository's entrypoint (filename of a map, from the repo's root) + -> IO (DirResult Full) +recursiveCheckDir config prefix root = do + maps <- recursiveCheckDir' config prefix [root] mempty + + let exitGraph = resultToGraph maps + -- maps that don't have (local) ways back to the main entrypoint + let nowayback = + unreachableFrom root + . invertGraph + $ exitGraph + + -- inject warnings for maps that have no way back to the entrypoint + let maps' = flip mapWithKey maps $ \path res -> + if path `elem` nowayback + then res { mapresultGeneral = + Hint Warning ("Cannot go back to " <> toText root <> " from this map.") + : mapresultGeneral res + } + else res + + mAssets <- missingAssets prefix maps' + pure $ DirResult { dirresultDeps = missingDeps root maps' + , dirresultMissingAssets = mAssets + , dirresultMaps = maps' + , dirresultGraph = + toText + . showDot + . graphToDot + . takeSubGraph 7 root + $ exitGraph + } + + +-- | Given a (partially) completed DirResult, check which local +-- maps are referenced but do not actually exist. +missingDeps :: FilePath -> Map FilePath (MapResult a) -> [MissingDep] +missingDeps entrypoint maps = + let simple = M.insert (toText entrypoint) [] used \\ M.union defined trivial + in M.foldMapWithKey (\f n -> [MissingDep (Just $ not ("#" `isInfixOf` f)) f n]) simple + where + -- which maps are linked somewhere? + used :: Map Text [FilePath] + used = M.fromList + $ M.foldMapWithKey + (\path v -> map (, [path]) . mapMaybe (extractLocalDeps path) . mapresultDepends $ v) + maps + where extractLocalDeps prefix = \case + LocalMap name -> Just $ toText $ normaliseWithFrag prefix name + _ -> Nothing + -- which are defined using startLayer? + defined :: Set Text + defined = setFromList + $ M.foldMapWithKey + (\k v -> map ((toText k <> "#") <>) . mapresultProvides $ v) + maps + -- each map file is an entrypoint by itself + trivial = mapKeys toText $ void maps + +-- | Checks if all assets referenced in the result actually exist as files +missingAssets :: FilePath -> Map FilePath (MapResult a) -> IO [MissingAsset] +missingAssets prefix maps = + mapM (fmap (fmap (fmap MissingAsset)) missingOfMap) (M.toList maps) <&> fold + where missingOfMap (path, mapres) = mapMaybeM + (\case Local relpath -> + let asset = normalise (takeDirectory path) relpath + in doesFileExist (prefix asset) <&> + \case True -> Nothing + False -> Just $ MissingDep Nothing (toText asset) [path] + _ -> pure Nothing) + (mapresultDepends mapres) + + +-- | recursive checking of all maps in a repository +recursiveCheckDir' + :: LintConfig' + -> FilePath + -- ^ the repo's directory + -> [FilePath] + -- ^ paths of maps yet to check + -> Map FilePath (MapResult Full) + -- ^ accumulator for map results + -> IO (Map FilePath (MapResult Full)) +recursiveCheckDir' config prefix paths !acc = do + + -- lint all maps in paths. The double fmap skips maps which cause IO errors + -- (in which case loadAndLintMap returns Nothing); appropriate warnings will + -- show up later during dependency checks + lints <- + let lintPath p = fmap (fmap (p,)) (loadAndLintMap config (prefix p) depth) + where depth = length (splitPath p) - 1 + in mapMaybeM lintPath paths >>= evaluateNF + + + let mapdeps = setFromList (concatMap extractDeps lints) + where extractDeps (mappath, lintresult) = + fmap (FP.normalise . normalise (takeDirectory mappath)) + . mapMaybe onlyLocalMaps + $ mapresultDepends lintresult + onlyLocalMaps = \case + LocalMap p -> Just p + _ -> Nothing + + let acc' = acc <> M.fromList lints + + -- newly found maps that still need to be checked + let unknowns = listFromSet $ M.difference mapdeps acc + + -- no further maps? return acc'. Otherwise, recurse + case unknowns of + [] -> pure acc' + _ -> recursiveCheckDir' config prefix unknowns acc' diff --git a/walint/CheckMap.hs b/walint/CheckMap.hs new file mode 100644 index 0000000..ef80a7f --- /dev/null +++ b/walint/CheckMap.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Module that contains the high-level checking functions +module CheckMap (loadAndLintMap, MapResult(..), ResultKind(..), Optional,shrinkMapResult) where + +import Universum + +import Data.Aeson (ToJSON (toJSON)) +import qualified Data.Aeson as A +import Data.Aeson.Types ((.=)) +import qualified Data.Map as M +import qualified Data.Text as T +import qualified Data.Vector as V + + +import Badges (Badge) +import Data.Tiled (Layer (layerLayers, layerName), + Tiledmap (tiledmapLayers, tiledmapTilesets), + loadTiledmap) +import LintConfig (LintConfig (..), LintConfig') +import LintWriter (LintResult, invertLintResult, + resultToAdjusted, resultToBadges, + resultToCWs, resultToDeps, resultToJitsis, + resultToLints, resultToOffers, runLintWriter) +import Properties (checkLayer, checkMap, checkTileset) +import System.FilePath (takeFileName) +import Types (Dep (MapLink), + Hint (Hint, hintLevel, hintMsg), Level (..), + lintsToHints) +import Util (PrettyPrint (prettyprint), prettyprint) + + +data ResultKind = Full | Shrunk + +type family Optional (a :: ResultKind) (b :: Type) where + Optional Full b = b + Optional Shrunk b = () + +-- | What this linter produces: lints for a single map +data MapResult (kind :: ResultKind) = MapResult + { mapresultLayer :: Map Hint [Text] + -- ^ lints that occurred in one or more layers + , mapresultTileset :: Map Hint [Text] + -- ^ lints that occurred in one or more tilesets + , mapresultDepends :: [Dep] + -- ^ (external and local) dependencies of this map + , mapresultProvides :: [Text] + -- ^ entrypoints provided by this map (needed for dependency checking) + , mapresultAdjusted :: Optional kind (Maybe Tiledmap) + -- ^ the loaded map, with adjustments by the linter + , mapresultBadges :: [Badge] + -- ^ badges that can be found on this map + , mapresultCWs :: [Text] + -- ^ collected CWs that apply to this map + , mapresultJitsis :: [Text] + -- ^ all jitsi room slugs mentioned in this map + , mapresultGeneral :: [Hint] + -- ^ general-purpose lints that didn't fit anywhere else + } deriving (Generic) + +instance NFData (Optional a (Maybe Tiledmap)) => NFData (MapResult a) + + +instance Eq (MapResult a) where + a == b = + mapresultLayer a == mapresultLayer b && + mapresultTileset a == mapresultTileset b && + -- mapresultBadges a == mapresultBadges b && + mapresultGeneral a == mapresultGeneral b + + +instance ToJSON (MapResult a) where + toJSON res = A.object + [ "layer" .= CollectedLints (mapresultLayer res) + , "tileset" .= CollectedLints (mapresultTileset res) + , "general" .= mapresultGeneral res + ] + +newtype CollectedLints = CollectedLints (Map Hint [Text]) + +instance ToJSON CollectedLints where + toJSON (CollectedLints col) = toJSON + . M.mapKeys hintMsg + $ M.mapWithKey (\h cs -> A.object [ "level" .= hintLevel h, "in" .= truncated cs ]) col + where truncated cs = if length cs > 10 + then take 9 cs <> [ "..." ] + else cs + + +shrinkMapResult :: MapResult Full -> MapResult Shrunk +shrinkMapResult !res = res { mapresultAdjusted = () } + +-- | this module's raison d'être +-- Lints the map at `path`, and limits local links to at most `depth` +-- layers upwards in the file hierarchy +loadAndLintMap :: LintConfig' -> FilePath -> Int -> IO (Maybe (MapResult Full)) +loadAndLintMap config path depth = loadTiledmap path <&> \case + 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) + +-- | lint a loaded map +runLinter :: Bool -> LintConfig' -> Tiledmap -> Int -> MapResult Full +runLinter isMain config@LintConfig{..} tiledmap depth = MapResult + { mapresultLayer = invertThing layer + , mapresultTileset = invertThing tileset + , mapresultGeneral = + [Hint Warning "main.json should link back to the lobby" + | isMain && not (any linksLobby layerDeps)] + <> lintsToHints (resultToLints generalResult) + , mapresultDepends = resultToDeps generalResult + <> layerDeps + <> concatMap resultToDeps tileset + , mapresultProvides = concatMap resultToOffers layer + , mapresultAdjusted = Just adjustedMap + , mapresultCWs = resultToCWs generalResult + , mapresultJitsis = concatMap resultToJitsis tileset + <> concatMap resultToJitsis layer + , mapresultBadges = concatMap resultToBadges layer + <> resultToBadges generalResult + } + where + linksLobby = \case + MapLink link -> + ("/@/"<>configEventSlug<>"/lobby") `T.isPrefixOf` link + || configAssemblyTag == "lobby" + _ -> False + layerDeps = concatMap resultToDeps layer + layer = checkLayerRec config depth (V.toList $ tiledmapLayers tiledmap) + tileset = checkThing tiledmapTilesets checkTileset + generalResult = runLintWriter config tiledmap depth checkMap + + checkThing getter checker = V.toList . V.map runCheck $ getter tiledmap + where runCheck thing = runLintWriter config thing depth checker + + -- | "inverts" a LintResult, i.e. groups it by lints instead of + -- layers / maps + invertThing thing = M.unionsWith (<>) $ fmap invertLintResult thing + + adjustedMap = (resultToAdjusted generalResult) + { tiledmapLayers = V.fromList + . fmap resultToAdjusted + $ take (length (tiledmapLayers tiledmap)) layer + , tiledmapTilesets = V.fromList + . fmap resultToAdjusted + $ tileset + } + +-- | Recursively checks a layer. +-- +-- This is apparently necessary because someone thought it would be a good +-- idea to have group layers, even if their entire semantics appear to be +-- "they're group layers"; they don't seem to /do/ anything … +-- +-- Note that this will flatten the layer structure and give them all back +-- in a single list, but the ones that were passed in will always be at +-- the head of the list. +checkLayerRec :: LintConfig' -> Int -> [Layer] -> [LintResult Layer] +checkLayerRec config depth layers = + -- reordering to get the correct ones back up front + (\rs -> fmap fst rs <> concatMap snd rs) + -- map over all input layers + $ flip fmap layers $ \parent -> + case layerLayers parent of + -- not a group layer; just lint this one + Nothing -> + (runLintWriter config parent depth checkLayer,[]) + -- this is a group layer. Fun! + Just sublayers -> + (parentResult, subresults) + where + -- Lintresults for sublayers with adjusted names + subresults :: [LintResult Layer] + subresults = + take (length sublayers) + . fmap (fmap (\l -> l { layerName = layerName parent <> "/" <> layerName l } )) + $ subresults' + + -- Lintresults for sublayers and subsublayers etc. + subresults' = + checkLayerRec config depth sublayers + + -- lintresult for the parent layer + parentResult = runLintWriter config parentAdjusted depth checkLayer + + -- the parent layer with adjusted sublayers + parentAdjusted = + parent { layerLayers = Just (fmap resultToAdjusted subresults') } + + + +-- human-readable lint output, e.g. for consoles +instance PrettyPrint (Level, MapResult a) where + prettyprint (_, mapResult) = if complete == "" + then " all good!\n" else complete + where + complete = T.concat $ prettyGeneral + <> prettyLints mapresultLayer + <> prettyLints mapresultTileset + + -- | pretty-prints a collection of Hints, printing each + -- Hint only once, then a list of its occurences line-wrapped + -- to fit onto a decent-sized terminal + prettyLints :: (MapResult a -> Map Hint [Text]) -> [Text] + prettyLints getter = fmap + (\(h, cs) -> prettyprint h + <> "\n (in " + <> snd (foldl (\(l,a) c -> case l of + 0 -> (T.length c, c) + _ | l < 70 -> (l+2+T.length c, a <> ", " <> c) + _ -> (6+T.length c, a <> ",\n " <> c) + ) + (0, "") cs) + <> ")\n") + (M.toList . getter $ mapResult) + + prettyGeneral :: [Text] + prettyGeneral = map + ((<> "\n") . prettyprint) + $ mapresultGeneral mapResult diff --git a/walint/Dirgraph.hs b/walint/Dirgraph.hs new file mode 100644 index 0000000..831933a --- /dev/null +++ b/walint/Dirgraph.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} + +-- | Simple directed graphs, for dependency checking +module Dirgraph where + +import Universum + +import CheckMap (MapResult (mapresultDepends)) +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 qualified Text.Dot as D +import Text.Dot (Dot, (.->.)) +import Types (Dep (LocalMap)) + +-- | a simple directed graph +type Graph a = Map a (Set a) + +nodes :: Graph a -> Set a +nodes = M.keysSet + +-- | simple directed graph of exits +resultToGraph :: Map FilePath (MapResult a) -> Graph FilePath +resultToGraph = fmap (S.fromList . mapMaybe onlyLocalMaps . mapresultDepends) + where onlyLocalMaps = \case + LocalMap path -> Just (normalise "" path) + _ -> Nothing + +-- | invert edges of a directed graph +invertGraph :: (Eq a, Ord a) => Graph a -> Graph a +invertGraph graph = mapWithKey collectFroms graph + where collectFroms to _ = S.fromList . elems . mapMaybeWithKey (select to) $ graph + select to from elems = if to `elem` elems then Just from else Nothing + +-- | all nodes reachable from some entrypoint +reachableFrom :: Ord a => a -> Graph a -> Set a +reachableFrom entrypoint graph = recursive mempty (S.singleton entrypoint) + where recursive seen current + | null current = seen + | otherwise = recursive (S.union seen current) (next \\ seen) + where next = S.unions + . S.fromList -- for some reason set is not filterable? + . mapMaybe (`M.lookup` graph) + . S.toList + $ current + +unreachableFrom :: Ord a => a -> Graph a -> Set a +unreachableFrom entrypoint graph = + nodes graph \\ reachableFrom entrypoint graph + +takeSubGraph :: (Eq a, Ord a) => Int -> a -> Graph a -> Graph a +takeSubGraph i start graph + | i <= 0 = mempty + | i == 1 = + M.singleton start reachable + `M.union` M.fromList ((,mempty) <$> S.toList reachable) + | otherwise = + M.singleton start reachable + `M.union` (M.unionsWith S.union + . S.map (flip (takeSubGraph (i-1)) graph) + $ reachable) + where reachable = fromMaybe mempty (M.lookup start graph) + +graphToDot :: Graph FilePath -> Dot () +graphToDot graph = do + main <- D.node [("label","main.json")] + nodes' <- M.traverseMaybeWithKey + (\name edges -> if name /= "main.json" + then D.node [("label",name)] <&> (, edges) <&> Just + else pure Nothing + ) + graph + + let reachable = fromMaybe mempty (M.lookup "main.json" graph) + let nodes = M.insert "main.json" (main,reachable) nodes' + forM_ nodes $ \(node, edges) -> + forM_ edges $ \key -> + case M.lookup key nodes of + Just (other,_) -> node .->. other + _ -> pure () diff --git a/walint/LayerData.hs b/walint/LayerData.hs new file mode 100644 index 0000000..82efbfc --- /dev/null +++ b/walint/LayerData.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} + +module LayerData where + +import Universum hiding (maximum, uncons) + +import Control.Monad.Zip (mzipWith) +import Data.Set (insert) +import Data.Tiled (GlobalId (unGlobalId), Layer (..)) +import Data.Vector (maximum, uncons) +import qualified Text.Show as TS +import Util (PrettyPrint (..)) + +-- | A collision between two layers of the given names. +-- Wrapped in a newtype so that Eq can ignore the order of the two +newtype Collision = Collision { fromCollision :: (Text, Text) } + deriving Ord + +instance Eq Collision where + (Collision (a,b)) == (Collision (a',b')) = ((a,b) == (a',b')) || ((a,b) == (b',a')) + +instance PrettyPrint Collision where + prettyprint (Collision (a,b)) = a <> " and " <> b + +instance TS.Show Collision where + show c = toString $ prettyprint c + +-- | Finds pairwise tile collisions between the given layers. +layerOverlaps :: Vector Layer -> Set Collision +layerOverlaps layers = case uncons layers of + Nothing -> mempty + Just (l, ls) -> + fst . foldr overlapBetween (mempty, l) $ ls + where overlapBetween :: Layer -> (Set Collision, Layer) -> (Set Collision, Layer) + overlapBetween layer (acc, oldlayer) = + (if collides then insert collision acc else acc, layer) + where + collision = Collision (layerName layer, layerName oldlayer) + collides = case (layerData layer, layerData oldlayer) of + (Just d1, Just d2) -> + 0 /= maximum (mzipWith (\a b -> unGlobalId a * unGlobalId b) d1 d2) + _ -> False diff --git a/walint/LintConfig.hs b/walint/LintConfig.hs new file mode 100644 index 0000000..8db46dd --- /dev/null +++ b/walint/LintConfig.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Module that deals with handling config options +module LintConfig (LintConfig(..), LintConfig', ConfigKind (..), patchConfig,stuffConfig,feedConfig) where + +import Universum + +import Data.Aeson (FromJSON (parseJSON), Options (..), + defaultOptions, eitherDecode) +import Data.Aeson.Types (genericParseJSON) +import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Lazy as LB +import qualified Data.Map.Strict as M +import GHC.Generics (Generic (Rep, from, to), K1 (..), + M1 (..), (:*:) (..)) +import Types (Level) +import Uris (SchemaSet, + Substitution (DomainSubstitution)) +import WithCli.Pure (Argument (argumentType, parseArgument)) + + + +data ConfigKind = Complete | Basic | Skeleton | Patch + +-- | a field that must be given in configs for both server & standalone linter +type family ConfigField (f::ConfigKind) a where + ConfigField Patch a = Maybe a + ConfigField _ a = a + +-- | a field that must be given for the standalone linter, but not the server +-- (usually because the server will infer them from its own config) +type family StandaloneField (f :: ConfigKind) a where + StandaloneField Complete a = a + StandaloneField Skeleton a = a + StandaloneField _ a = Maybe a + +-- | a field specific to a single world / assembly +type family WorldField (f :: ConfigKind) a where + WorldField Complete a = a + WorldField _ a = Maybe a + +data LintConfig (f :: ConfigKind) = LintConfig + { configScriptInject :: ConfigField f (Maybe Text) + -- ^ Link to Script that should be injected + , configAssemblyTag :: WorldField f Text + -- ^ Assembly name (used for jitsiRoomAdminTag) + , configAssemblies :: StandaloneField f [Text] + -- ^ list of all assembly slugs (used to lint e.g. world:// links) + , configEventSlug :: StandaloneField f Text + -- ^ slug of this event (used e.g. to resolve world:// links) + , configMaxLintLevel :: ConfigField f Level + -- ^ Maximum warn level allowed before the lint fails + , configDontCopyAssets :: ConfigField f Bool + -- ^ Don't copy map assets (mostly useful for development) + , configAllowScripts :: ConfigField f Bool + -- ^ Allow defining custom scripts in maps + , configUriSchemas :: ConfigField f SchemaSet + } deriving (Generic) + +type LintConfig' = LintConfig Complete + +deriving instance Show (LintConfig Complete) +deriving instance Show (LintConfig Skeleton) +deriving instance Show (LintConfig Patch) +instance NFData (LintConfig Basic) + +aesonOptions :: Options +aesonOptions = defaultOptions + { omitNothingFields = True + , rejectUnknownFields = True + , fieldLabelModifier = drop 6 + } + +instance FromJSON (LintConfig Complete) where + parseJSON = genericParseJSON aesonOptions + +instance FromJSON (LintConfig Patch) where + parseJSON = genericParseJSON aesonOptions + +instance FromJSON (LintConfig Basic) where + parseJSON = genericParseJSON aesonOptions + + + +-- | generic typeclass for things that are "patchable" +class GPatch i m where + gappend :: i p -> m p -> i p + +-- generic instances. It's category theory, but with confusing names! +instance GPatch (K1 a k) (K1 a (Maybe k)) where + gappend _ (K1 (Just k')) = K1 k' + gappend (K1 k) (K1 Nothing) = K1 k + {-# INLINE gappend #-} + +instance (GPatch i o, GPatch i' o') + => GPatch (i :*: i') (o :*: o') where + gappend (l :*: r) (l' :*: r') = gappend l l' :*: gappend r r' + {-# INLINE gappend #-} + +instance GPatch i o + => GPatch (M1 _a _b i) (M1 _a' _b' o) where + gappend (M1 x) (M1 y) = M1 (gappend x y) + {-# INLINE gappend #-} + + +-- | A patch function. For (almost) and a :: * -> *, +-- take an a Identity and an a Maybe, then replace all appropriate +-- values in the former with those in the latter. +-- +-- There isn't actually any useful reason for this function to be this +-- abstract, I just wanted to play around with higher kinded types for +-- a bit. +patch :: + ( Generic (f Patch) + , Generic (f Complete) + , GPatch (Rep (f Complete)) + (Rep (f Patch)) + ) + => f Complete + -> f Patch + -> f Complete +patch x y = to (gappend (from x) (from y)) + +patchConfig + :: LintConfig Complete + -> Maybe (LintConfig Patch) + -> LintConfig Complete +patchConfig config p = expandWorlds config' + where + config' = case p of + Just p -> patch config p + Nothing -> config + + +-- | feed a basic server config +feedConfig + :: LintConfig Basic + -> [Text] + -> Text + -> LintConfig Skeleton +feedConfig LintConfig{..} worlds eventslug = expandWorlds $ + LintConfig + { configAssemblies = worlds + , configEventSlug = eventslug + , .. } + +-- | stuff a +stuffConfig :: LintConfig Skeleton -> Text -> LintConfig Complete +stuffConfig LintConfig{..} assemblyslug = + LintConfig + { configAssemblyTag = assemblyslug + , ..} + +class HasWorldList (a :: ConfigKind) +instance HasWorldList 'Complete +instance HasWorldList 'Skeleton + +-- kinda sad that ghc can't solve these contraints automatically, +-- though i guess it also makes sense … +expandWorlds + :: ( ConfigField a SchemaSet ~ SchemaSet + , StandaloneField a [Text] ~ [Text] + , StandaloneField a Text ~ Text + , HasWorldList a) + => LintConfig a -> LintConfig a +expandWorlds config = config { configUriSchemas = configUriSchemas' } + where + configUriSchemas' = + M.insert "world:" [assemblysubsts] (configUriSchemas config) + assemblysubsts = + DomainSubstitution (M.fromList generated) ["map"] + where generated = configAssemblies config + <&> \slug -> (slug, "/@/"<>configEventSlug config<>"/"<>slug) + +instance (FromJSON (LintConfig a)) => Argument (LintConfig a) where + parseArgument str = + case eitherDecode (LB.fromStrict $ C8.pack str) of + Left _ -> Nothing + Right res -> Just res + + argumentType Proxy = "LintConfig" diff --git a/walint/LintWriter.hs b/walint/LintWriter.hs new file mode 100644 index 0000000..40d54bb --- /dev/null +++ b/walint/LintWriter.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} + +-- | a monad that collects warnings, outputs, etc, +module LintWriter + ( runLintWriter + , LintWriter + , LintWriter' + , LintResult + , invertLintResult + , zoom + -- * working with lint results + , resultToDeps + , resultToOffers + , resultToBadges + , resultToLints + , resultToAdjusted + -- * Add lints to a linter + , info + , suggest + , warn + , forbid + , complain + -- * add other information to the linter + , offersEntrypoint + , offersBadge + , dependsOn + -- * get information about the linter's context + , askContext + , askFileDepth + , lintConfig + -- * adjust the linter's context + , adjust + ,offersCWs,resultToCWs,offersJitsi,resultToJitsis) where + +import Universum + + +import Badges (Badge) +import Data.Map (fromListWith) +import Data.Tiled.Abstract (HasName (getName)) +import LintConfig (LintConfig') +import Types (Dep, Hint, Level (..), Lint (..), hint, + lintsToHints) + + +-- | A monad modelling the main linter features +type LintWriter ctxt = LintWriter' ctxt () +-- | A linter that can use pure / return things monadically +type LintWriter' ctxt res = + StateT (LinterState ctxt) (Reader (Context, ctxt, LintConfig')) res + +-- | A Linter's state: some context (which it may adjust), and a list of lints +-- | it already collected. +newtype LinterState ctxt = LinterState + { fromLinterState :: ([Lint], ctxt)} + deriving Functor + +-- | The result of running a linter: an adjusted context, and a list of lints. +-- | This is actually just a type synonym of LinterState, but kept seperately +-- | for largely historic reasons since I don't think I'll change it again +type LintResult ctxt = LinterState ctxt + +-- | for now, all context we have is how "deep" in the directory tree +-- we currently are +type Context = Int + +-- | run a linter. Returns the adjusted context, and a list of lints +runLintWriter + :: LintConfig' -> ctxt -> Context -> LintWriter ctxt -> LintResult ctxt +runLintWriter config context depth linter = LinterState + . fromLinterState + . snd + . runReader runstate + $ (depth, context, config) + where runstate = runStateT linter (LinterState ([], context)) + + +zoom :: (a -> b) -> (b -> a) -> LintWriter a -> LintWriter' b a +zoom embed extract operation = do + config <- lintConfig id + depth <- askFileDepth + let result ctxt = runLintWriter config ctxt depth operation + LinterState (lints,a) <- get + let res = result . extract $ a + put $ LinterState + . (resultToLints res <> lints,) + . embed + . resultToAdjusted + $ res + pure $ resultToAdjusted res + + +-- | "invert" a linter's result, grouping lints by their messages +invertLintResult :: HasName ctxt => LintResult ctxt -> Map Hint [Text] +invertLintResult (LinterState (lints, ctxt)) = + fmap (sortNub . map getName) . fromListWith (<>) $ (, [ctxt]) <$> lintsToHints lints + +resultToDeps :: LintResult a -> [Dep] +resultToDeps (LinterState (lints,_)) = mapMaybe lintToDep lints + where lintToDep = \case + Depends dep -> Just dep + _ -> Nothing + +resultToOffers :: LintResult a -> [Text] +resultToOffers (LinterState a) = mapMaybe lintToOffer $ fst a + where lintToOffer = \case + Offers frag -> Just frag + _ -> Nothing + +resultToBadges :: LintResult a -> [Badge] +resultToBadges (LinterState a) = mapMaybe lintToBadge $ fst a + where lintToBadge (Badge badge) = Just badge + lintToBadge _ = Nothing + +resultToCWs :: LintResult a -> [Text] +resultToCWs (LinterState a) = fold $ mapMaybe lintToCW $ fst a + where lintToCW = \case (CW cw) -> Just cw; _ -> Nothing + +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] +resultToLints (LinterState res) = fst res + +-- | extract the adjusted context from a lint result +resultToAdjusted :: LintResult a -> a +resultToAdjusted (LinterState res) = snd res + + + + +-- | fundamental linter operations: add a lint of some severity +info = lint Info +suggest = lint Suggestion +warn = lint Warning +forbid = lint Forbidden +complain = lint Error + +-- | add a dependency to the linter +dependsOn :: Dep -> LintWriter a +dependsOn dep = tell' $ Depends dep + +-- | add an offer for an entrypoint to the linter +offersEntrypoint :: Text -> LintWriter a +offersEntrypoint text = tell' $ Offers text + +-- | add an offer for a badge to the linter +offersBadge :: Badge -> LintWriter a +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 +askContext = lift $ asks (\(_,a,_) -> a) + +-- | ask for the file depth within the repository tree of the current map. +-- | This function brings in a lot more conceptual baggage than I'd like, but +-- | it's needed to check if relative paths lie outside the repository +askFileDepth :: LintWriter' a Int +askFileDepth = lift $ asks (\(a,_,_) -> a) + +-- | ask for a specific part of the linter's global config +lintConfig :: (LintConfig' -> a) -> LintWriter' ctxt a +lintConfig get = lift $ asks (\(_,_,config) -> get config) + + + + +-- | tell, but for a singular lint. Leaves the context unchanged +tell' :: Lint -> LintWriter ctxt +tell' l = modify $ \(LinterState (lints, ctxt)) -> LinterState (l:lints, ctxt) + +-- | small helper to tell a singlular proper lint +lint :: Level -> Text -> LintWriter a +lint level text = tell' $ hint level text + +-- | adjusts the context. Gets a copy of the /current/ context, +-- | i.e. one which might have already been changed by other adjustments +adjust :: (a -> a) -> LintWriter a +adjust f = modify $ LinterState . second f . fromLinterState diff --git a/walint/Paths.hs b/walint/Paths.hs new file mode 100644 index 0000000..f4dc3ed --- /dev/null +++ b/walint/Paths.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Paths are horrible, so they have their own module now. +-- I just hope you are running this on some kind of Unix +module Paths where + +import Universum +import qualified Universum.Unsafe as Unsafe + +import qualified Data.Text as T +import System.FilePath (splitPath) +import System.FilePath.Posix (()) +import Text.Regex.TDFA +import Util (PrettyPrint (prettyprint)) + + +-- | a normalised path: a number of "upwards" steps, and +-- a path without any . or .. in it. Also possibly a +-- fragment, mostly for map links. +data RelPath = Path Int Text (Maybe Text) + deriving (Show, Eq, Ord, NFData, Generic) + + + +data PathResult = OkRelPath RelPath + | AbsolutePath + | NotAPath + | UnderscoreMapLink + | AtMapLink + | PathVarsDisallowed + +-- | horrible regex parsing for filepaths that is hopefully kinda safe +parsePath :: Text -> PathResult +parsePath text = + if | T.isInfixOf "{{" text || T.isInfixOf "}}" text -> PathVarsDisallowed + | rest =~ ("^([^/]*[^\\./]/)*[^/]*[^\\./]$" :: Text) -> OkRelPath (Path up path fragment) + | "/_/" `T.isPrefixOf` text -> UnderscoreMapLink + | "/@/" `T.isPrefixOf` text -> AtMapLink + | "/" `T.isPrefixOf` text -> AbsolutePath + | otherwise -> NotAPath + where + (_, prefix, rest, _) = + text =~ ("^((\\.|\\.\\.)/)*" :: Text) :: (Text, Text, Text, [Text]) + -- how many steps upwards in the tree? + up = length . filter (".." ==) . T.splitOn "/" $ prefix + parts = T.splitOn "#" rest + -- `head` is unsafe, but splitOn will always produce lists with at least one element + path = Unsafe.head parts + fragment = case nonEmpty parts of + Nothing -> Nothing + Just p -> Just $ T.concat $ tail p + +instance PrettyPrint RelPath where + prettyprint (Path up rest frag) = ups <> rest <> fragment + where ups = T.concat $ replicate up "../" + fragment = maybe mempty ("#" <>) frag + +-- | Normalises a path. +-- +-- It takes a `prefix`, and will "truncate" the .. operator +-- at the end of the prefix, i.e. it will never return paths +-- that lie (naïvely) outside of the prefix. +normalise :: FilePath -> RelPath -> FilePath +normalise prefix (Path 0 path _) = prefix toString path +normalise prefix (Path i path _) = + concat (take (length dirs - i) dirs) toString path + where dirs = splitPath prefix + +normaliseWithFrag :: FilePath -> RelPath -> FilePath +normaliseWithFrag prefix (Path i path frag) = + normalise prefix (Path (i+1) path frag) <> toString (maybe mempty ("#" <>) frag) + +-- | does this path contain an old-style pattern for inter-repository +-- links as was used at rc3 in 2020? +isOldStyle :: RelPath -> Bool +isOldStyle (Path _ text frag) = path =~ ("{<.+>*}" :: Text) + where path = case frag of + Just f -> text <> f + _ -> text + +getExtension :: RelPath -> Text +getExtension (Path _ text _) = maybe "" last (nonEmpty splitted) + where splitted = T.splitOn "." text diff --git a/walint/Properties.hs b/walint/Properties.hs new file mode 100644 index 0000000..7b5a181 --- /dev/null +++ b/walint/Properties.hs @@ -0,0 +1,748 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Contains checks for custom ties of the map json +module Properties (checkMap, checkTileset, checkLayer) where + +import Universum hiding (intercalate, isPrefixOf) + +import Data.Text (intercalate, isPrefixOf) +import qualified Data.Text as T +import Data.Tiled (Layer (..), Object (..), Property (..), + PropertyValue (..), Tile (..), + Tiledmap (..), Tileset (..)) +import Data.Tiled.Abstract (HasData (..), HasName (..), + HasProperties (..), HasTypeName (..), + IsProperty (..), layerIsEmpty) +import qualified Data.Vector as V +import Util (mkProxy, naiveEscapeHTML, prettyprint) + +import Badges (Badge (Badge), + BadgeArea (BadgePoint, BadgeRect), + BadgeToken, parseToken) +import Data.List ((\\)) +import qualified Data.Set as S +import Data.Text.Metrics (damerauLevenshtein) +import GHC.TypeLits (KnownSymbol) +import LayerData (Collision, layerOverlaps) +import LintConfig (LintConfig (..)) +import LintWriter (LintWriter, adjust, askContext, + askFileDepth, complain, dependsOn, forbid, + lintConfig, offersBadge, offersCWs, + offersEntrypoint, offersJitsi, suggest, + warn, zoom) +import Paths (PathResult (..), RelPath (..), + getExtension, isOldStyle, parsePath) +import Types (Dep (Link, Local, LocalMap, MapLink)) +import Uris (SubstError (..), applySubsts) + + +knownMapProperties :: Vector Text +knownMapProperties = V.fromList + [ "mapName", "mapDescription", "mapCopyright", "mapLink", "script" + , "contentWarnings" ] + +knownTilesetProperties :: Vector Text +knownTilesetProperties = V.fromList + [ "tilesetCopyright", "collides"] + +knownObjectProperties :: Vector Text +knownObjectProperties = V.fromList + [ "name", "url", "getBadge", "soundRadius", "default", "persist", "openLayer" + , "closeLayer", "door", "bell", "openSound", "closeSound", "bellSound" + , "allowapi"] + +knownTileLayerProperites :: Vector Text +knownTileLayerProperites = V.fromList + [ "jitsiRoom", "jitsiTrigger", "jitsiTriggerMessage", "jitsiWidth" + , "playAudio", "audioLoop", "audioVolumne" + , "openWebsite", "openWebsiteTrigger", "openWebsiteTriggerMessage", "openTag" + , "exitUrl", "startLayer", "silent", "getBadge", "zone", "name", "doorVariable" + , "bindVariable", "bellVariable", "code", "openTriggerMessage" + , "closeTriggerMessage", "autoOpen", "autoClose", "bellButtonText", "bellPopup" + , "enterValue", "leaveValue" ] + +-- | Checks an entire map for "general" lints. +-- +-- Note that it does /not/ check any tile layer/tileset properties; +-- these are handled seperately in CheckMap, since these lints go +-- into a different field of the output. +checkMap :: LintWriter Tiledmap +checkMap = do + tiledmap <- askContext + let layers = collectLayers tiledmap + let unlessLayer = unlessElement layers + + -- test custom map properties + mapM_ checkMapProperty (maybeToMonoid $ tiledmapProperties tiledmap) + + -- can't have these with the rest of layer/tileset lints since they're + -- not specific to any one of them + refuseDoubledNames layers + refuseDoubledNames (tiledmapTilesets tiledmap) + refuseDoubledNames (getProperties tiledmap) + + -- some layers should exist + unlessElementNamed layers "start" + $ complain "The map must have one layer named \"start\"." + unlessLayer (\l -> getName l == "floorLayer" && layerType l == "objectgroup") + $ complain "The map must have one layer named \"floorLayer\" of type \"objectgroup\"." + unlessLayer (`containsProperty` "exitUrl") + $ complain "The map must contain at least one layer with the property \"exitUrl\" set." + + -- reject maps not suitable for workadventure + unless (tiledmapOrientation tiledmap == "orthogonal") + $ complain "The map's orientation must be set to \"orthogonal\"." + unless (tiledmapTileheight tiledmap == 32 && tiledmapTilewidth tiledmap == 32) + $ complain "The map's tile size must be 32 by 32 pixels." + + unlessHasProperty "mapCopyright" + $ suggest "document the map's copyright via the \"mapCopyright\" property." + + unlessHasProperty "contentWarnings" + $ suggest "set content warnings for your map via the \"contentWarnings\" property." + + -- TODO: this doesn't catch collisions with the default start layer! + whenLayerCollisions layers (\(Property name _) -> name == "exitUrl" || name == "startLayer") + $ \cols -> warn $ "collisions between entry and / or exit layers: " <> prettyprint cols + + let missingMetaInfo = + ["mapName","mapDescription","mapLink"] + \\ map getName (getProperties tiledmap) + + unless (null missingMetaInfo) + $ suggest $ "consider adding meta information to your map using the " + <> prettyprint missingMetaInfo <> " properties." + + where + -- recursively find all layers (to deal with nested group layers) + collectLayers :: Tiledmap -> V.Vector Layer + collectLayers tiledmap = tiledmapLayers tiledmap <> + V.fromList (concatMap groupmembers (tiledmapLayers tiledmap)) + where groupmembers :: Layer -> [Layer] + groupmembers layer = concatMap groupmembers layers <> layers + where layers = fromMaybe [] $ layerLayers layer + +-- | Checks a single property of a map. +checkMapProperty :: Property -> LintWriter Tiledmap +checkMapProperty p@(Property name _) = case name of + "mapName" -> naiveEscapeProperty p + "mapDescription" -> naiveEscapeProperty p + "mapCopyright" -> naiveEscapeProperty p + "mapLink" -> pure () + "contentWarnings" -> + unwrapString p $ \str -> do + offersCWs (T.splitOn "," str) + -- usually the linter will complain if names aren't in their + -- "canonical" form, but allowing that here so that multiple + -- scripts can be used by one map + _ | T.toLower name == "script" -> + unwrapURI (Proxy @"script") p + (dependsOn . Link) + (const $ forbid "scripts loaded from local files are disallowed") + | name `elem` ["jitsiRoom", "playAudio", "openWebsite" + , "url", "exitUrl", "silent", "getBadge"] + -> complain $ "property " <> name + <> " should be set on layers, not the map directly" + | otherwise + -> warnUnknown p knownMapProperties + + +-- | check an embedded tileset. +-- +-- Important to collect dependency files +checkTileset :: LintWriter Tileset +checkTileset = do + tileset <- askContext + case tilesetImage tileset of + Just str -> unwrapPath str (dependsOn . Local) + Nothing -> complain "Tileset does not refer to an image." + + refuseDoubledNames (getProperties tileset) + + -- reject tilesets unsuitable for workadventure + unless (tilesetTilewidth tileset == 32 && tilesetTileheight tileset == 32) + $ complain "Tilesets must have tile size 32x32." + + when (tilesetImageheight tileset > 4096 || tilesetImagewidth tileset > 4096) + $ warn "Tilesets should not be larger than 4096x4096 pixels in total." + + when (isJust (tilesetSource tileset)) + $ complain "Tilesets must be embedded and cannot be loaded from external files." + + unlessHasProperty "tilesetCopyright" + $ forbid "property \"tilesetCopyright\" for tilesets must be set." + + when (isJust (tilesetFileName tileset)) + $ complain "The \"filename\" property on tilesets was removed; use \"image\" instead (and perhaps a newer version of the Tiled Editor)." + + -- check properties of individual tiles + tiles' <- forM (tilesetTiles tileset) $ mapM $ \tile -> do + mapM_ (checkTileProperty tile) (getProperties tile) + zoom (const tileset) (const tile) $ mapM_ (checkTileThing True) (getProperties tile) + + adjust (\t -> t { tilesetTiles = tiles' }) + + -- check individual tileset properties + mapM_ checkTilesetProperty (maybeToMonoid $ tilesetProperties tileset) + + case tilesetTiles tileset of + Nothing -> pure () + Just tiles -> ifDoubledThings tileId + -- can't set properties on the same tile twice + (\tile -> complain $ "cannot set properties on the \ + \tile with the id" <> show (tileId tile) <> "twice.") + tiles + + where + checkTilesetProperty :: Property -> LintWriter Tileset + checkTilesetProperty p@(Property name _value) = case name of + "tilesetCopyright" -> naiveEscapeProperty p + "collides" -> warn "property \"collides\" should be set on individual tiles, not the tileset" + _ -> warn $ "unknown tileset property " <> prettyprint name + + checkTileProperty :: Tile -> Property -> LintWriter Tileset + checkTileProperty tile p@(Property name _) = + case name of + "collides" -> isBool p + -- named tiles are needed for scripting and do not hurt otherwise + "name" -> isString p + "tilesetCopyright" -> warn "the \"tilesetCopyright\" property should be set on the entire tileset, \ + \not an individual tile." + _ -> warnUnknown' ("unknown tile property " + <> prettyprint name <> " in tile with global id " + <> show (tileId tile)) p knownTilesetProperties + + +-- | collect lints on a single map layer +checkLayer :: LintWriter Layer +checkLayer = do + layer <- askContext + + refuseDoubledNames (getProperties layer) + + when (isJust (layerImage layer)) + $ complain "imagelayer are not supported." + + case layerType layer of + "tilelayer" -> mapM_ (checkTileThing False) (getProperties layer) + "group" -> pure () + "objectgroup" -> do + + -- check object properties + objs <- forM (layerObjects layer) $ mapM $ \object -> do + -- this is a confusing constant zoom ... + zoom (const layer) (const object) $ mapM_ checkObjectProperty (getProperties object) + adjust (\l -> l { layerObjects = objs }) + + -- all objects which don't define badges + let publicObjects = map (V.filter (not . (`containsProperty` "getBadge"))) objs + + -- remove badges from output + adjust $ \l -> l { layerObjects = publicObjects + , layerProperties = Nothing } + + -- check layer properties + forM_ (getProperties layer) checkObjectGroupProperty + + unless (layerName layer == "floorLayer") $ + when (isNothing (layerObjects layer) || layerObjects layer == Just mempty) $ + warn "objectgroup layer (which aren't the floorLayer) \ + \are useless if they are empty." + + ty -> complain $ "unsupported layer type " <> prettyprint ty <> "." + + if layerType layer == "group" + then when (isNothing (layerLayers layer)) + $ warn "Empty group layers are pointless." + else when (isJust (layerLayers layer)) + $ complain "Layer is not of type \"group\", but has sublayers." + +checkObjectProperty :: Property -> LintWriter Object +checkObjectProperty p@(Property name _) = do + obj <- askContext + case name of + "url" -> do + unwrapURI (Proxy @"website") p + (dependsOn . Link) + (const $ forbid "using \"url\" to open local html files is disallowed.") + unless (objectType obj == "website") + $ complain "\"url\" can only be set for objects of type \"website\"" + "getBadge" -> do + when (1 /= length (getProperties obj)) + $ warn "Objects with the property \"getBadge\" set are removed at runtime, \ + \and any other properties set on them will be gone." + unwrapString p $ \str -> + unwrapBadgeToken str $ \token -> do + case obj of + ObjectPolygon {} -> complain "polygons are not supported." + ObjectPolyline {} -> complain "polylines are not supported." + ObjectText {} -> complain "cannot use texts to define badge areas." + ObjectRectangle {..} -> + if objectEllipse == Just True + then complain "ellipses are not supported." + else offersBadge + $ Badge token $ case (objectWidth, objectHeight) of + (Just w, Just h) | w /= 0 && h /= 0 -> + BadgeRect objectX objectY w h + _ -> BadgePoint objectX objectY + "soundRadius" -> do + isIntInRange 0 maxBound p + unless (containsProperty obj "door" || containsProperty obj "bell") + $ complain "property \"soundRadius\" can only be set on objects with \ + \either property \"bell\" or \"door\" also set." + + _ | name `elem` [ "default", "persist" ] -> + suggestPropertyName' "door" + -- extended API for doors and bells + | name `elem` [ "openLayer", "closeLayer" ] -> do + isString p + suggestPropertyName' "door" + -- extended API for doors and bells + | name `elem` ["door", "bell"] -> do + isBool p + unless (objectType obj == "variable") $ + complain $ "the "<>prettyprint name<>" property should only be set \ + \on objects of type \"variable\"" + when (isNothing (objectName obj) || objectName obj == Just mempty) $ + complain $ "Objects with the property "<>prettyprint name<>" set must \ + \be named." + | name `elem` [ "openSound", "closeSound", "bellSound", "loadSound" ] -> do + isString p + unwrapURI (Proxy @"audio") p + (dependsOn . Link) + (dependsOn . Local) + case name of + "bellSound" -> + suggestPropertyName' "bell" + "closeSound" | containsProperty obj "openSound" -> + suggestPropertyName' "door" + _ -> do + suggestPropertyName' "door" + suggestPropertyName "soundRadius" + "set \"soundRadius\" to limit the door sound to a certain area." + | T.toLower name == "allowapi" + -> forbidProperty name + | otherwise -> + warnUnknown p knownObjectProperties + +-- | Checks a single (custom) property of an objectgroup layer +checkObjectGroupProperty :: Property -> LintWriter Layer +checkObjectGroupProperty (Property name _) = case name of + "getBadge" -> warn "the property \"getBadge\" must be set on individual objects, \ + \not the object layer." + _ -> warn $ "unknown property " <> prettyprint name <> " for objectgroup layers" + + + +-- | Checks a single (custom) property. Since almost all properties +-- can be set on tile layer AND on tilesets, this function aims to +-- be generic over both — the only difference is that tilesets can't +-- have exits, which is specified by the sole boolean argument +checkTileThing + :: (HasProperties a, HasName a, HasData a) + => Bool -> Property -> LintWriter a +checkTileThing removeExits p@(Property name _value) = case name of + "jitsiRoom" -> do + uselessEmptyLayer + -- members of an assembly should automatically get + -- admin rights in jitsi (prepending "assembly-" here + -- to avoid namespace clashes with other admins) + lintConfig configAssemblyTag + >>= setProperty "jitsiRoomAdminTag" + . ("assembly-" <>) + unwrapString p $ \jitsiRoom -> do + suggestProperty $ Property "jitsiTrigger" "onaction" + + -- prevents namespace clashes for jitsi room names + 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" + $ suggest "set \"jitsiTriggerMessage\" to a custom message to overwrite \ + \the default \"press SPACE to enter in jitsi meet room\"." + requireProperty "jitsiRoom" + "jitsiTriggerMessage" -> do + isString p + requireProperty "jitsiTrigger" + "jitsiWidth" -> + isIntInRange 0 100 p + "playAudio" -> do + uselessEmptyLayer + unwrapURI (Proxy @"audio") p + (dependsOn . Link) + (dependsOn . Local) + "audioLoop" -> do + isBool p + requireProperty "playAudio" + "playAudioLoop" -> + deprecatedUseInstead "audioLoop" + "audioVolume" -> do + isOrdInRange unwrapFloat 0 1 p + requireProperty "playAudio" + "openWebsiteTrigger" -> do + isString p + requireOneOf ["openWebsite", "openTab"] + unlessHasProperty "openWebsiteTriggerMessage" + $ suggest "set \"openWebsiteTriggerMessage\" to a custom message to \ + \overwrite the default \"press SPACE to open Website\"." + "openWebsiteTriggerMessage" -> do + isString p + requireProperty "openWebsiteTrigger" + "url" -> complain "the property \"url\" defining embedded iframes must be \ + \set on an object in an objectgroup layer." + "exitUrl" -> if not removeExits + then do + forbidEmptyLayer + unwrapURI (Proxy @"map") p + (\link -> do + assemblyslug <- lintConfig configAssemblyTag + eventslug <- lintConfig configEventSlug + case T.stripPrefix ("/@/"<>eventslug<>"/"<>assemblyslug<>"/") link of + Nothing -> do + dependsOn (MapLink link) + setProperty "exitUrl" link + Just path -> case parsePath path of + OkRelPath (Path _ p frag) -> do + up <- askFileDepth + dependsOn (LocalMap (Path up p frag)) + setProperty "exitUrl" path + warn "You should use relative links to your own assembly instead \ + \of world://-style links (I've tried to adjust them \ + \automatically for now)." + _ -> complain "There's a path I don't understand here. Perhaps try \ + \asking a human?" + ) + ( \path -> + let ext = getExtension path in + if | isOldStyle path -> do + eventslug <- lintConfig configEventSlug + complain $ + "Old-Style inter-repository links (using {}) \ + \cannot be used at "<>eventslug<>"; please use world:// \ + \instead (see the howto)." + | ext == "tmx" -> + complain "Cannot use .tmx map format; use Tiled's json export instead." + | ext /= "json" -> + complain "All exit links must link to .json files." + | otherwise -> dependsOn . LocalMap $ path + ) + else do + warn "exitUrls in Tilesets are not unsupported; if you want to \ + \add an exit, please use a tile layer instead." + "exitSceneUrl" -> + deprecatedUseInstead "exitUrl" + "exitInstance" -> + deprecatedUseInstead "exitUrl" + "startLayer" -> do + forbidEmptyLayer + layer <- askContext + unwrapBool p $ \case + True -> offersEntrypoint $ getName layer + False -> warn "property \"startLayer\" is useless if set to false." + "silent" -> do + isBool p + uselessEmptyLayer + "getBadge" -> complain "\"getBadge\" must be set on an \"objectgroup\" \ + \ layer; it does not work on tile layers." + + -- extended API stuff + "zone" -> do + isString p + uselessEmptyLayer + -- name on tile layer unsupported + "name" -> isUnsupported + _ | name `elem` [ "doorVariable", "bindVariable", "bellVariable" ] + -> do { isString p; requireProperty "zone" } + | name `elem` [ "code", "openTriggerMessage", "closeTriggerMessage"] + -> do { isString p; requireProperty "doorVariable" } + | name `elem` [ "autoOpen", "autoClose"] + -> do { isBool p; requireProperty "doorVariable" } + | name `elem` [ "bellButtonText", "bellPopup" ] + -> do { isString p; requireProperty "bellVariable" } + | name `elem` [ "enterValue", "leaveValue" ] + -> do { isString p; requireProperty "bindVariable" } + | T.toLower name `elem` [ "jitsiurl", "jitsiconfig", "jitsiclientconfig" + , "jitsiroomadmintag", "jitsiinterfaceconfig" + , "openwebsitepolicy", "allowapi" ] + -> forbidProperty name + | name `elem` [ "openWebsite", "openTab" ] -> do + uselessEmptyLayer + suggestProperty $ Property "openWebsiteTrigger" "onaction" + + properties <- askContext <&> getProperties + let isScript = any (\(Property name _) -> + T.toLower name == "openwebsiteallowapi") + properties + if isScript + then unwrapURI (Proxy @"script") p + (dependsOn . Link) + (const $ forbid "accessing local html files is disallowed") + else unwrapURI (Proxy @"website") p + (dependsOn . Link) + (const $ forbid "accessing local html files is disallowed.") + | otherwise -> + when (not removeExits || name `notElem` [ "collides", "name", "tilesetCopyright" ]) $ do + warnUnknown p knownTileLayerProperites + where + requireProperty req = propertyRequiredBy req name + requireOneOf names = do + context <- askContext + unless (any (containsProperty context) names) + $ complain $ "property " <> prettyprint name <> " requires one of " + <> prettyprint names + + isUnsupported = warn $ "property " <> name <> " is not (yet) supported by walint." + deprecatedUseInstead instead = + warn $ "property \"" <> name <> "\" is deprecated. Use \"" <> instead <> "\" instead." + + -- | this property can only be used on a layer that contains + -- | at least one tile + forbidEmptyLayer = when removeExits $ do + layer <- askContext + when (layerIsEmpty layer) + $ complain ("property " <> prettyprint name <> " should not be set on an empty layer.") + + -- | this layer is allowed, but also useless on a layer that contains no tiles + uselessEmptyLayer = when removeExits $ do + layer <- askContext + when (layerIsEmpty layer) + $ warn ("property " <> prettyprint name <> " set on an empty layer is useless.") + + +-- | refuse doubled names in everything that's somehow a collection of names +refuseDoubledNames + :: (Container t, HasName (Element t), HasTypeName (Element t)) + => t + -> LintWriter b +refuseDoubledNames = ifDoubledThings getName + (\thing -> complain $ "cannot use " <> typeName (mkProxy thing) <> " name " + <> getName thing <> " multiple times.") + +-- | do `ifDouble` if any element of `things` occurs more than once under +-- the function `f` +ifDoubledThings + :: (Eq a, Ord a, Container t) + => (Element t -> a) + -> (Element t -> LintWriter b) + -> t + -> LintWriter b +ifDoubledThings f ifDouble things = foldr folding base things (mempty, mempty) + where + folding thing cont (seen, twice) + | f thing `elem` seen && f thing `notElem` twice = do + ifDouble thing + cont (seen, S.insert (f thing) twice) + | otherwise = + cont (S.insert (f thing) seen, twice) + base _ = pure () + +-- | we don't know this property; give suggestions for ones with similar names +warnUnknown' :: Text -> Property -> Vector Text -> LintWriter a +warnUnknown' msg (Property name _) knowns = + if snd minDist < 4 + then warn (msg <> ", perhaps you meant " <> prettyprint (fst minDist) <> "?") + else warn msg + where dists = V.map (\n -> (n, damerauLevenshtein name n)) knowns + minDist = V.minimumBy (\(_,a) (_,b) -> compare a b) dists + +warnUnknown :: Property -> Vector Text -> LintWriter a +warnUnknown p@(Property name _) = + warnUnknown' ("unknown property " <> prettyprint name) p + +---- General functions ---- + +unlessElement + :: Container f + => f + -> (Element f -> Bool) + -> LintWriter b + -> LintWriter b +unlessElement things op = unless (any op things) + +unlessElementNamed :: (HasName (Element f), Container f) + => f -> Text -> LintWriter b -> LintWriter b +unlessElementNamed things name = + unlessElement things ((==) name . getName) + +unlessHasProperty :: HasProperties a => Text -> LintWriter a -> LintWriter a +unlessHasProperty name linter = + askContext >>= \ctxt -> + unlessElementNamed (getProperties ctxt) name linter + +-- | does this layer have the given property? +containsProperty :: HasProperties a => a -> Text -> Bool +containsProperty thing name = any + (\(Property name' _) -> name' == name) (getProperties thing) + +-- | should the layers fulfilling the given predicate collide, then perform andthen. +whenLayerCollisions + :: V.Vector Layer + -> (Property -> Bool) + -> (Set Collision -> LintWriter a) + -> LintWriter a +whenLayerCollisions layers f andthen = do + let collisions = layerOverlaps . V.filter (any f . getProperties) $ layers + unless (null collisions) + $ andthen collisions + +----- Functions with concrete lint messages ----- + +-- | this property is forbidden and should not be used +forbidProperty :: HasProperties a => Text -> LintWriter a +forbidProperty name = + forbid $ "property " <> prettyprint name <> " is disallowed." + +propertyRequiredBy :: HasProperties a => Text -> Text -> LintWriter a +propertyRequiredBy req by = + unlessHasProperty req + $ complain $ "property " <> prettyprint req <> + " is required by property " <> prettyprint by <> "." + +-- | suggest some value for another property if that property does not +-- also already exist +suggestProperty :: HasProperties a => Property -> LintWriter a +suggestProperty p@(Property name value) = + suggestProperty' p $ "add property " <> prettyprint name <> " to \"" <> prettyprint value<>"\"." + +suggestProperty' :: HasProperties a => Property -> Text -> LintWriter a +suggestProperty' (Property name _) msg = + unlessHasProperty name (suggest msg) + +suggestPropertyName :: HasProperties a => Text -> Text -> LintWriter a +suggestPropertyName name msg = + unlessHasProperty name (suggest msg) + +suggestPropertyName' :: HasProperties a => Text -> LintWriter a +suggestPropertyName' name = suggestPropertyName name + $ "consider setting property " <> prettyprint name <> "." + +---- Functions for adjusting the context ----- + + +-- | set a property, overwriting whatever value it had previously +setProperty :: (IsProperty prop, HasProperties ctxt) + => Text -> prop -> LintWriter ctxt +setProperty name value = adjust $ \ctxt -> + flip adjustProperties ctxt + $ \ps -> Just $ Property name (asProperty value) : filter sameName ps + where sameName (Property name' _) = name /= name' + +naiveEscapeProperty :: HasProperties a => Property -> LintWriter a +naiveEscapeProperty prop@(Property name _) = + unwrapString prop (setProperty name . naiveEscapeHTML) + +---- "unwrappers" checking that a property has some type, then do something ---- + +-- | asserts that this property is a string, and unwraps it +unwrapString :: Property -> (Text -> LintWriter a) -> LintWriter a +unwrapString (Property name value) f = case value of + StrProp str -> f str + _ -> complain $ "type error: property " + <> prettyprint name <> " should be of type string." + + +-- | asserts that this property is a boolean, and unwraps it +unwrapBool :: Property -> (Bool -> LintWriter a) -> LintWriter a +unwrapBool (Property name value) f = case value of + BoolProp b -> f b + _ -> complain $ "type error: property " <> prettyprint name + <> " should be of type bool." + +unwrapInt :: Property -> (Int -> LintWriter a) -> LintWriter a +unwrapInt (Property name value) f = case value of + IntProp float -> f float + _ -> complain $ "type error: property " <> prettyprint name + <> " should be of type int." + +unwrapFloat :: Property -> (Float -> LintWriter a) -> LintWriter a +unwrapFloat (Property name value) f = case value of + FloatProp float -> f float + _ -> complain $ "type error: property " <> prettyprint name + <> " should be of type float." + +unwrapPath :: Text -> (RelPath -> LintWriter a) -> LintWriter a +unwrapPath str f = case parsePath str of + OkRelPath p@(Path up _ _) -> do + depth <- askFileDepth + if up <= depth + then f p + else complain $ "cannot acess paths \"" <> str <> "\" which is outside your repository." + NotAPath -> complain $ "path \"" <> str <> "\" is invalid." + AbsolutePath -> forbid "absolute paths are disallowed. Use world:// instead." + UnderscoreMapLink -> forbid "map links using /_/ are disallowed. Use world:// instead." + AtMapLink -> forbid "map links using /@/ are disallowed. Use world:// instead." + PathVarsDisallowed -> forbid "extended API variables are not allowed in asset paths." + +unwrapBadgeToken :: Text -> (BadgeToken -> LintWriter a) -> LintWriter a +unwrapBadgeToken str f = case parseToken str of + Just a -> f a + Nothing -> complain "invalid badge token." + + +-- | unwraps a link, giving two cases: +-- - the link might be an (allowed) remote URI +-- - the link might be relative to this map (i.e. just a filepath) +unwrapURI :: (KnownSymbol s, HasProperties a) + => Proxy s + -> Property + -> (Text -> LintWriter a) + -> (RelPath -> LintWriter a) + -> LintWriter a +unwrapURI sym p@(Property name _) f g = unwrapString p $ \link -> do + subst <- lintConfig configUriSchemas + case applySubsts sym subst link of + Right uri -> do + setProperty name uri + f uri + Left NotALink -> unwrapPath link g + Left err -> do + isLobby <- lintConfig configAssemblyTag <&> (== "lobby") + + (if isLobby then warn else complain) $ case err of + DomainIsBlocked domains -> link <> " is a blocked site; links in this \ + \context may link to " <> prettyprint domains + IsBlocked -> link <> " is blocked." + DomainDoesNotExist domain -> "The domain " <> domain <> " does not exist; \ + \please make sure it is spelled correctly." + SchemaDoesNotExist schema -> + "the URI schema " <> schema <> "// cannot be used." + WrongScope schema allowed -> + "the URI schema " <> schema <> "// cannot be used in property \ + \\"" <> name <> "\"; allowed " + <> (if length allowed == 1 then "is " else "are ") + <> intercalate ", " (map (<> "//") allowed) <> "." + VarsDisallowed -> "extended API links are disallowed in links" + + + +-- | just asserts that this is a string +isString :: Property -> LintWriter a +isString = flip unwrapString (const $ pure ()) + +-- | just asserts that this is a boolean +isBool :: Property -> LintWriter a +isBool = flip unwrapBool (const $ pure ()) + +isIntInRange :: Int -> Int -> Property -> LintWriter b +isIntInRange = isOrdInRange @Int unwrapInt + +isOrdInRange :: (Ord a, Show a) + => (Property -> (a -> LintWriter b) -> LintWriter b) + -> a + -> a + -> Property + -> LintWriter b +isOrdInRange unwrapa l r p@(Property name _) = unwrapa p $ \int -> + if l < int && int < r then pure () + else complain $ "Property " <> prettyprint name <> " should be between " + <> show l <> " and " <> show r<>"." diff --git a/walint/Types.hs b/walint/Types.hs new file mode 100644 index 0000000..746fc00 --- /dev/null +++ b/walint/Types.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + + +-- | basic types for the linter to eat and produce +-- The dark magic making thse useful is in LintWriter +module Types + ( Level(..) + , Lint(..) + , Dep(..) + , Hint(..) + , hint + , lintLevel + , lintsToHints + ) where + +import Universum + +import Control.Monad.Trans.Maybe () +import Data.Aeson (FromJSON, ToJSON (toJSON), + ToJSONKey, (.=)) + +import Badges (Badge) +import qualified Data.Aeson as A +import Paths (RelPath) +import Util (PrettyPrint (..)) +import WithCli (Argument, atomicArgumentsParser) +import WithCli.Pure (Argument (argumentType, parseArgument), + HasArguments (argumentsParser)) + + +-- | Levels of errors and warnings, collectively called +-- "Hints" until I can think of some better name +data Level = Info | Suggestion | Warning | Forbidden | Error | Fatal + deriving (Show, Generic, Ord, Eq, ToJSON, FromJSON, NFData) + +instance Argument Level where + argumentType Proxy = "Lint Level" + parseArgument arg = case arg of + "info" -> Just Info + "suggestion" -> Just Suggestion + "warning" -> Just Warning + "forbidden" -> Just Forbidden + "error" -> Just Error + "fatal" -> Just Fatal + _ -> Nothing + + +instance HasArguments Level where + argumentsParser = atomicArgumentsParser + +-- | 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] | Jitsi Text + deriving (Ord, Eq, Generic) + +data Dep = Local RelPath | Link Text | MapLink Text | LocalMap RelPath + deriving (Generic, Ord, Eq, NFData) + +data Hint = Hint + { hintLevel :: Level + , hintMsg :: Text + } deriving (Generic, Ord, Eq, NFData) + +-- | shorter constructor (called hint because (a) older name and +-- (b) lint also exists and is monadic) +hint :: Level -> Text -> Lint +hint level msg = Lint Hint { hintLevel = level, hintMsg = msg } + +-- | dependencies just have level Info +lintLevel :: Lint -> Level +lintLevel (Lint h) = hintLevel h +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 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 Hint where + toJSON (Hint l m) = A.object + [ "msg" .= m, "level" .= l ] + +instance ToJSON Dep where + toJSON = \case + Local text -> json "local" $ prettyprint text + Link text -> json "link" text + MapLink text -> json "mapservice" text + LocalMap text -> json "map" $ prettyprint text + where + json :: A.Value -> Text -> A.Value + json kind text = A.object [ "kind" .= kind, "dep" .= text ] + +instance PrettyPrint Dep where + prettyprint = \case + Local dep -> "[local dep: " <> prettyprint dep <> "]" + Link dep -> "[link dep: " <> dep <> "]" + MapLink dep -> "[map service dep: " <> dep <> "]" + LocalMap dep -> "[local map dep: " <> prettyprint dep <> "]" diff --git a/walint/Uris.hs b/walint/Uris.hs new file mode 100644 index 0000000..cb15b47 --- /dev/null +++ b/walint/Uris.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Functions to deal with uris and custom uri schemes +module Uris where + +import Universum + +import Data.Aeson (FromJSON (..), Options (..), + SumEncoding (UntaggedValue), + defaultOptions, genericParseJSON) +import qualified Data.Map.Strict as M +import qualified Data.Text as T +import GHC.TypeLits (KnownSymbol, symbolVal) +import Network.URI (URI (..), URIAuth (..), parseURI, + uriToString) +import qualified Network.URI.Encode as URI + +data Substitution = + Prefixed { prefix :: Text, blocked :: [Text], allowed :: [Text], scope :: [String] } + | DomainSubstitution { substs :: Map Text Text, scope :: [String] } + | Allowed { scope :: [String], allowed :: [Text] } + | Unrestricted { scope :: [String] } + deriving (Generic, Show, NFData) + + +instance FromJSON Substitution where + parseJSON = genericParseJSON defaultOptions + { sumEncoding = UntaggedValue + , rejectUnknownFields = True + } + +type SchemaSet = Map Text [Substitution] + + +-- | deconstruct a URI into a triple of [schema:]//[domain]/[tail...], +-- and a normalised version of the same URI +parseUri :: Text -> Maybe (Text, Text, Text, Text) +parseUri raw = + case parseURI (toString (T.strip raw)) of + Nothing -> Nothing + Just uri@URI{..} -> case uriAuthority of + Nothing -> Nothing + Just URIAuth {..} -> Just + ( fromString uriScheme + , fromString $ uriUserInfo <> uriRegName <> uriPort + , fromString $ uriPath <> uriQuery <> uriFragment + , fromString $ uriToString id uri "" + ) + + +data SubstError = + SchemaDoesNotExist Text + | NotALink + | DomainDoesNotExist Text + | IsBlocked + | DomainIsBlocked [Text] + | VarsDisallowed + | WrongScope Text [Text] + -- ^ This link's schema exists, but cannot be used in this scope. + -- The second field contains a list of schemas that may be used instead. + deriving (Eq, Ord) -- errors are ordered so we can show more specific ones + + +applySubsts :: KnownSymbol s + => Proxy s -> SchemaSet -> Text -> Either SubstError Text +applySubsts s substs uri = do + when (T.isInfixOf "{{" uri || T.isInfixOf "}}" uri) + $ Left VarsDisallowed + parts@(schema, _, _, _) <- maybeToRight NotALink $ parseUri uri + + let rules = filter (elem thisScope . scope) . concat $ M.lookup schema substs + + case nonEmpty $ map (applySubst parts) rules of + Nothing -> Left (SchemaDoesNotExist schema) + Just result -> minimum result + where + thisScope = symbolVal s + applySubst (schema, domain, rest, uri) rule = do + + -- is this scope applicable? + unless (symbolVal s `elem` scope rule) + $ Left (WrongScope schema + $ map fst -- make list of available uri schemes + . filter (any (elem thisScope . scope) . snd) + $ toPairs substs) + + case rule of + DomainSubstitution table _ -> do + prefix <- case M.lookup domain table of + Nothing -> Left (DomainDoesNotExist (schema <> "//" <> domain)) + Just a -> Right a + pure (prefix <> rest) + Prefixed {..} + | domain `elem` blocked -> Left IsBlocked + | domain `elem` allowed -> Right uri + | otherwise -> Right (prefix <> URI.encodeText uri) + Allowed _ allowlist + | domain `elem` allowlist -> Right uri + | otherwise -> Left (DomainIsBlocked allowlist) + Unrestricted _ -> Right uri diff --git a/walint/Util.hs b/walint/Util.hs new file mode 100644 index 0000000..ef35139 --- /dev/null +++ b/walint/Util.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Util + ( mkProxy + , PrettyPrint(..) + , printPretty + , naiveEscapeHTML + , ellipsis + ) where + +import Universum + +import Data.Aeson as Aeson +import qualified Data.Set as S +import qualified Data.Text as T +import Data.Tiled (Layer, PropertyValue (..), Tileset (tilesetName), + layerName) + +-- | helper function to create proxies +mkProxy :: a -> Proxy a +mkProxy = const Proxy + +-- | a class to address all the string conversions necessary +-- when using Show to much that just uses Text instead +class PrettyPrint a where + prettyprint :: a -> Text + +-- | let's see if this is a good idea or makes type inference bite us +instance PrettyPrint Text where + prettyprint text = "\"" <> text <> "\"" + +-- | same as show json, but without the "String" prefix for json strings +instance PrettyPrint Aeson.Value where + prettyprint = \case + Aeson.String s -> prettyprint s + v -> show v + +instance PrettyPrint t => PrettyPrint (Set t) where + prettyprint = prettyprint . S.toList + +instance PrettyPrint PropertyValue where + prettyprint = \case + StrProp str -> str + BoolProp bool -> if bool then "true" else "false" + IntProp int -> show int + FloatProp float -> show float + +-- | here since Unit is sometimes used as dummy type +instance PrettyPrint () where + prettyprint _ = error "shouldn't pretty-print Unit" + +instance PrettyPrint Layer where + prettyprint = (<>) "layer " . layerName + +instance PrettyPrint Tileset where + prettyprint = (<>) "tileset " . tilesetName + +instance PrettyPrint a => PrettyPrint [a] where + prettyprint = T.intercalate ", " . fmap prettyprint + +printPretty :: PrettyPrint a => a -> IO () +printPretty = putStr . toString . prettyprint + + +-- | for long lists which shouldn't be printed out in their entirety +ellipsis :: Int -> [Text] -> Text +ellipsis i texts + | i < l = prettyprint (take i texts) <> " ... (and " <> show (l-i) <> " more)" + | otherwise = prettyprint texts + where l = length texts + + + +-- | naive escaping of html sequences, just to be sure that +-- | workadventure won't mess things up again … +naiveEscapeHTML :: Text -> Text +naiveEscapeHTML = T.replace "<" "<" . T.replace ">" ">" diff --git a/walint/WriteRepo.hs b/walint/WriteRepo.hs new file mode 100644 index 0000000..325b301 --- /dev/null +++ b/walint/WriteRepo.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} + + +-- | Module for writing an already linted map Repository back out again. +module WriteRepo (writeAdjustedRepository) where + +import Universum + +import CheckDir (DirResult (..), resultIsFatal) +import CheckMap (MapResult (..), ResultKind (..)) +import Data.Aeson (encodeFile) +import qualified Data.Set as S +import LintConfig (LintConfig (configDontCopyAssets), + LintConfig') +import Paths (normalise) +import System.Directory.Extra (copyFile, createDirectoryIfMissing, + doesDirectoryExist) +import System.Exit (ExitCode (..)) +import qualified System.FilePath as FP +import System.FilePath (takeDirectory) +import System.FilePath.Posix (()) +import Types (Dep (Local)) + + +-- TODO: make this return a custom error type, not an exitcode +writeAdjustedRepository :: LintConfig' -> FilePath -> FilePath -> DirResult Full -> IO ExitCode +writeAdjustedRepository config inPath outPath result + | resultIsFatal config result = + pure (ExitFailure 1) + | otherwise = do + ifM (doesDirectoryExist outPath) (pure (ExitFailure 2)) $ do + createDirectoryIfMissing True outPath + + -- write out all maps + forM_ (toPairs $ dirresultMaps result) $ \(path,out) -> do + createDirectoryIfMissing True (takeDirectory (outPath path)) + encodeFile (outPath path) $ mapresultAdjusted out + + unless (configDontCopyAssets config) $ do + -- collect asset dependencies of maps + -- TODO: its kinda weird doing that here, tbh + let localdeps :: Set FilePath = + S.fromList . concatMap + (\(mappath,mapresult) -> + let mapdir = takeDirectory mappath in + mapMaybe (\case + Local path -> Just . normalise mapdir $ path + _ -> Nothing) + $ mapresultDepends mapresult) + . toPairs $ dirresultMaps result + + -- copy all assets + forM_ localdeps $ \path -> + let + assetPath = FP.normalise $ inPath path + newPath = FP.normalise $ outPath path + in do + createDirectoryIfMissing True (takeDirectory newPath) + copyFile assetPath newPath + + pure ExitSuccess diff --git a/walint/default.nix b/walint/default.nix new file mode 100644 index 0000000..d36072b --- /dev/null +++ b/walint/default.nix @@ -0,0 +1,17 @@ +{ mkDerivation, aeson, base, bytestring, containers, deepseq +, dotgen, either, extra, filepath, getopt-generics, lib +, network-uri, regex-tdfa, text, text-metrics, tiled, transformers +, universum, uri-encode, vector +}: +mkDerivation { + pname = "walint"; + version = "0.1"; + src = ./.; + libraryHaskellDepends = [ + aeson base bytestring containers deepseq dotgen either extra + filepath getopt-generics network-uri regex-tdfa text text-metrics + tiled transformers universum uri-encode vector + ]; + homepage = "https://stuebinm.eu/git/walint"; + license = "unknown"; +} diff --git a/walint/walint.cabal b/walint/walint.cabal new file mode 100644 index 0000000..3672d55 --- /dev/null +++ b/walint/walint.cabal @@ -0,0 +1,48 @@ +cabal-version: 3.0 +name: walint +version: 0.1 +author: stuebinm +maintainer: stuebinm@disroot.org +copyright: 2023 stuebinm +homepage: https://stuebinm.eu/git/walint + +library + exposed-modules: + CheckDir + CheckMap + WriteRepo + Util + Types + LintConfig + other-modules: + Badges + Dirgraph + LayerData + LintWriter + Paths + Properties + Uris + default-extensions: + NoImplicitPrelude + ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors + build-depends: + aeson + , base + , bytestring + , containers + , deepseq + , dotgen + , either + , extra + , filepath + , getopt-generics + , network-uri + , regex-tdfa + , text + , text-metrics + , tiled + , transformers + , universum + , uri-encode + , vector + default-language: GHC2021 -- cgit v1.2.3