From 65e7f9e8463353f82bcfd71e88309f8c6be3dbb0 Mon Sep 17 00:00:00 2001 From: Remo Rechkemmer <59358383+monacoremo@users.noreply.github.com> Date: Tue, 6 Apr 2021 11:46:12 +0200 Subject: [PATCH] nix: Add a tool for checking Haskell imports and exports (#1768) --- .gitignore | 1 - default.nix | 8 +- nix/devtools.nix | 75 ++++-- nix/hsie/Main.hs | 358 +++++++++++++++++++++++++ nix/hsie/README.md | 67 +++++ nix/hsie/default.nix | 30 +++ postgrest.cabal | 2 - shell.nix | 2 + src/PostgREST/Config.hs | 1 + src/PostgREST/Private/QueryFragment.hs | 3 +- src/PostgREST/Statements.hs | 1 + 11 files changed, 516 insertions(+), 32 deletions(-) create mode 100644 nix/hsie/Main.hs create mode 100644 nix/hsie/README.md create mode 100644 nix/hsie/default.nix diff --git a/.gitignore b/.gitignore index d6f521cb76..d00cdb788a 100644 --- a/.gitignore +++ b/.gitignore @@ -21,4 +21,3 @@ __pycache__ *.tix coverage .hpc -imports.png diff --git a/default.nix b/default.nix index 6ef1ca8593..7c5ac22d61 100644 --- a/default.nix +++ b/default.nix @@ -124,9 +124,15 @@ rec { style = pkgs.callPackage nix/style.nix { }; + # Tooling for analyzing Haskell imports and exports. + hsie = + pkgs.callPackage nix/hsie { + ghcWithPackages = pkgs.haskell.packages."${compiler}".ghcWithPackages; + }; + # Development tools, including linting and styling scripts. devtools = - pkgs.callPackage nix/devtools.nix { inherit tests style devCabalOptions; }; + pkgs.callPackage nix/devtools.nix { inherit tests style devCabalOptions hsie; }; # Scripts for publishing new releases. release = diff --git a/nix/devtools.nix b/nix/devtools.nix index b3a0bc6cb3..f51c8b4942 100644 --- a/nix/devtools.nix +++ b/nix/devtools.nix @@ -4,6 +4,7 @@ , devCabalOptions , entr , graphviz +, hsie , silver-searcher , style , tests @@ -98,40 +99,57 @@ let ${style}/bin/postgrest-style-check ''; - importsgraph = + dumpMinimalImports = checkedShellScript { - name = "postgrest-importsgraph"; - docs = - '' - Render the imports between PostgREST modules as a graph. - - Output is written to 'imports.png' in the root directory of the project. - ''; + name = "postgrest-dump-minimal-imports"; + docs = "Dump minimal imports into given directory."; inRootDir = true; } '' - imports=$( - grep -rE 'import .*PostgREST\.' src main \ - | sed -E \ - -e 's|/|\.|g' \ - -e 's/(src|main)\.(.*)\.hs:import .*(PostgREST\.\S+)( .*)?/"\2" -> "\3"/' - ) + dumpdir="$1" + tmpdir="$(mktemp -d)" + mkdir -p "$dumpdir" + ${cabal-install}/bin/cabal v2-build ${devCabalOptions} \ + --builddir="$tmpdir" \ + --ghc-option=-ddump-minimal-imports \ + --ghc-option=-dumpdir="$dumpdir" \ + 1>&2 + rm -rf "$tmpdir" - labels=$( - grep -rE '^(--)?\s*Description\s*:' src main \ - | sed -E \ - -e 's|/|\.|g' \ - -e 's/^(src|main)\.(.*)\.hs:(--)?\s*Description\s*:\s*(.*)$/"\2" [label="\2\\n\4"]/' - ) + # Fix OverloadedRecordFields imports + # shellcheck disable=SC2016 + sed -E 's/\$sel:.*://g' -i "$dumpdir"/* + ''; - cat < imports.png - digraph { - $imports - $labels - } - EOF + hsieMinimalImports = + checkedShellScript + { + name = "postgrest-hsie-minimal-imports"; + docs = "Run hsie with a provided dump of minimal imports."; + } + '' + tmpdir="$(mktemp -d)" + ${dumpMinimalImports} "$tmpdir" + ${hsie} "$tmpdir" "$@" + rm -rf "$tmpdir" ''; + + hsieGraphModules = + checkedShellScript + { + name = "postgrest-hsie-graph-modules"; + docs = "Create a PNG graph of modules imported within the codebase."; + } + ''${hsie} graph-modules main src | ${graphviz}/bin/dot -Tpng -o "$1"''; + + hsieGraphSymbols = + checkedShellScript + { + name = "postgrest-hsie-graph-symbols"; + docs = "Create a PNG graph of symbols imported within the codebase."; + } + ''${hsieMinimalImports} graph-symbols | ${graphviz}/bin/dot -Tpng -o "$1"''; in buildEnv { name = "postgrest-devtools"; @@ -142,6 +160,9 @@ buildEnv { run.bin clean.bin check.bin - importsgraph.bin + dumpMinimalImports.bin + hsieMinimalImports.bin + hsieGraphModules.bin + hsieGraphSymbols.bin ]; } diff --git a/nix/hsie/Main.hs b/nix/hsie/Main.hs new file mode 100644 index 0000000000..494dfa4777 --- /dev/null +++ b/nix/hsie/Main.hs @@ -0,0 +1,358 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Haskell Imports and Exports tool +-- +-- This tool parses imports and exports from Haskell source files and provides +-- analysis on these imports. For example, you can check whether consistent +-- import aliases are used across your codebase. + +module Main (main) where + +import qualified Data.Aeson as JSON +import qualified Data.ByteString.Lazy.Char8 as LBS8 +import qualified Data.Csv as Csv +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Dot +import qualified GHC +import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint +import qualified Options.Applicative as O +import qualified System.FilePath as FP + +import Data.Aeson.Encode.Pretty (encodePretty) +import Data.Function ((&)) +import Data.List (intercalate) +import Data.Maybe (catMaybes, mapMaybe) +import Data.Text (Text) +import GHC.Generics (Generic) +import HsExtension (GhcPs) +import Module (moduleNameString) +import OccName (occNameString) +import RdrName (rdrNameOcc) +import System.Directory.Recursive (getFilesRecursive) +import System.Exit (exitFailure) + +-- TYPES + +data Options = + Options + { command :: Command + , sources :: [FilePath] + } + +data Command + = Dump OutputFormat + | GraphSymbols + | GraphModules + | CheckAliases + | CheckWildcards [Text] + +data OutputFormat = OutputCsv | OutputJson + +data ImportedSymbol = + ImportedSymbol + { impFromModule :: Text + , impModule :: Text + , impQualified :: ImportQualified + , impAlias :: Maybe Text + , impType :: ImportType + , impSymbol :: Maybe Text + , impInternal :: ModuleInternal + , impSource :: FilePath + , impFile :: FilePath + } + deriving (Generic, Csv.ToNamedRecord, Csv.DefaultOrdered, JSON.ToJSON) + +data ImportQualified + = Qualified + | NotQualified + deriving (Eq, Generic, JSON.ToJSON) + +instance Csv.ToField ImportQualified where + toField Qualified = "qualified" + toField NotQualified = "not qualified" + +data ModuleInternal + = Internal + | External + deriving (Eq, Generic, JSON.ToJSON) + +instance Csv.ToField ModuleInternal where + toField Internal = "internal" + toField External = "external" + +data ImportType + = Wildcard + | Hiding + | Explicit + deriving (Eq, Generic, JSON.ToJSON) + +instance Csv.ToField ImportType where + toField Wildcard = "wildcard" + toField Hiding = "hiding" + toField Explicit = "explicit" + +-- | Mapping of modules to their aliases and to the files they are found in +type ModuleAliases = [(Text, [(Text, [FilePath])])] + +-- | Mapping of modules to files +type WildcardImports = [(FilePath, [Text])] + + +-- MAIN + +main :: IO () +main = + run =<< O.customExecParser prefs infoOpts + where + prefs = O.prefs $ O.subparserInline <> O.showHelpOnEmpty + infoOpts = + O.info (O.helper <*> opts) $ + O.fullDesc + <> O.header "hsie - Swiss army knife for HaSkell Imports and Exports" + <> O.progDesc "Parse Haskell code to analyze imports and exports" + opts = + Options <$> commandOption <*> O.some srcOption + srcOption = + O.argument O.str $ + O.metavar "SRCDIR" + <> O.help "Haskell source directory" + <> O.action "directory" + commandOption = + O.subparser $ + command "dump-imports" "Dump imported symbols as CSV or JSON" + (Dump <$> jsonOutputFlag) + <> command "graph-modules" "Print dot graph of module imports" + (pure GraphModules) + <> command "graph-symbols" "Print dot graph of symbol imports" + (pure GraphSymbols) + <> command "check-aliases" + "Check that aliases of imported modules are consistent" + (pure CheckAliases) + <> command "check-wildcards" + "Check that no modules are imported as unqualified wildcards" + (CheckWildcards <$> O.many okModuleOption) + command name desc options = + O.command name . O.info (O.helper <*> options) $ O.progDesc desc + jsonOutputFlag = + O.flag OutputCsv OutputJson $ + O.long "json" <> O.short 'j' <> O.help "Output JSON" + okModuleOption = + O.strOption $ + O.long "ok" + <> O.short 'o' + <> O.metavar "OKMODULE" + <> O.help "Module that is ok to import as unqualified wildcard" + +run :: Options -> IO () +run Options{command, sources} = + runCommand command . markInternal . concat =<< mapM sourceSymbols sources + where + runCommand :: Command -> [ImportedSymbol] -> IO () + runCommand (Dump format) = LBS8.putStr . dump format + runCommand GraphSymbols = T.putStr . symbolsGraph + runCommand GraphModules = T.putStr . Dot.encode . modulesGraph + runCommand CheckAliases = runInconsistentAliases . inconsistentAliases + runCommand (CheckWildcards okModules) = runWildcards . wildcards okModules + + runInconsistentAliases :: ModuleAliases -> IO () + runInconsistentAliases [] = T.putStrLn "No inconsistent module aliases found." + runInconsistentAliases xs = T.putStr (formatInconsistentAliases xs) >> exitFailure + + runWildcards :: WildcardImports -> IO () + runWildcards [] = T.putStrLn "No unwanted wildcard imports found." + runWildcards xs = T.putStr (formatWildcards xs) >> exitFailure + +-- | Mark imports from modules that are among the analyzed ones as internal. +markInternal :: [ImportedSymbol] -> [ImportedSymbol] +markInternal symbols = + fmap mark symbols + where + mark s = s { impInternal = if isInternal s then Internal else External } + isInternal = flip Set.member internalModules . impModule + internalModules = Set.fromList $ fmap impFromModule symbols + + +-- SYMBOLS + +-- | Parse all imported symbols from a source of Haskell source files +sourceSymbols :: FilePath -> IO [ImportedSymbol] +sourceSymbols source = do + files <- filterExts [".hs", ".imports"] <$> getFilesRecursive source + concat <$> mapM moduleSymbols files + where + filterExts exts = filter $ flip elem exts . FP.takeExtension + moduleSymbols filepath = do + GHC.HsModule{..} <- parseModule filepath + return $ concatMap (importSymbols source filepath . GHC.unLoc) hsmodImports + +-- | Parse a Haskell module +parseModule :: String -> IO (GHC.HsModule GhcPs) +parseModule filepath = do + result <- ExactPrint.parseModule filepath + case result of + Right (_, hsmod) -> + return $ GHC.unLoc hsmod + Left (loc, err) -> + fail $ "Error with " <> show filepath <> " at " <> show loc <> ": " <> err + +-- | Symbols imported in an import declaration. +-- +-- If the import is a wildcard, i.e. no symbols are selected for import, then +-- only one item is returned. +importSymbols :: FilePath -> FilePath -> GHC.ImportDecl GhcPs -> [ImportedSymbol] +importSymbols _ _ (GHC.XImportDecl _) = mempty +importSymbols source filepath GHC.ImportDecl{..} = + case ideclHiding of + Just (hiding, syms) -> + symbol (if hiding then Hiding else Explicit) . Just . GHC.unLoc <$> GHC.unLoc syms + Nothing -> + [ symbol Wildcard Nothing ] + where + symbol hiding sym = + ImportedSymbol + { impFile = relativePath filepath + , impSource = source + , impFromModule = T.pack $ moduleFromPath filepath + , impModule = T.pack . moduleNameString . GHC.unLoc $ ideclName + , impQualified = if ideclQualified then Qualified else NotQualified + , impAlias = T.pack . moduleNameString . GHC.unLoc <$> ideclAs + , impInternal = External + , impType = hiding + , impSymbol = T.pack . occNameString . rdrNameOcc . GHC.ieName <$> sym + } + moduleFromPath = + intercalate "." . FP.splitDirectories . FP.dropExtension . relativePath + relativePath = FP.makeRelative source + + +-- DUMP + +-- | Dump list of symbols as CSV or JSON +dump :: OutputFormat -> [ImportedSymbol] -> LBS8.ByteString +dump OutputCsv = Csv.encodeDefaultOrderedByName +dump OutputJson = encodePretty + + +-- ALIASES + +-- | Find modules that are imported under different aliases +inconsistentAliases :: [ImportedSymbol] -> ModuleAliases +inconsistentAliases symbols = + fmap moduleAlias symbols + & foldr insertSetMapMap Map.empty + & Map.map (aliases . Map.toList) + & Map.filter ((<) 1 . length) + & Map.toList + where + moduleAlias ImportedSymbol{..} = + (impModule, impAlias, FP.joinPath [impSource, impFile]) + insertSetMapMap (k1, k2, v) = + Map.insertWith (Map.unionWith Set.union) k1 + (Map.singleton k2 $ Set.singleton v) + aliases :: [(Maybe Text, Set.Set FilePath)] -> [(Text, [FilePath])] + aliases = mapMaybe (\(k, v) -> fmap (, Set.toList v) k) + +formatInconsistentAliases :: ModuleAliases -> Text +formatInconsistentAliases modules = + "The following imports have inconsistent aliases:\n\n" + <> T.concat (fmap formatModule modules) + where + formatModule (modName, aliases) = + "Module '" + <> modName + <> "' has the aliases:\n" + <> T.concat (fmap formatAlias aliases) + <> "\n" + formatAlias (alias, sourceFiles) = + " '" + <> alias + <> "' in file" + <> (if length sourceFiles > 2 then "s" else "") + <> ":\n" + <> T.concat (fmap formatFile sourceFiles) + formatFile sourceFile = + " " <> T.pack sourceFile <> "\n" + + +-- WILDCARDS + +-- | Find modules that are imported as wildcards, excluding whitelisted modules. +-- +-- Wildcard imports are ones that are not qualified and do not specify which +-- symbols should be imported. +wildcards :: [Text] -> [ImportedSymbol] -> WildcardImports +wildcards okModules = + groupByFile . filter isWildcard . filter (not . isOkModule) + where + isWildcard ImportedSymbol{..} = + impQualified == NotQualified && impType /= Explicit + isOkModule = flip Set.member (Set.fromList okModules) . impModule + groupByFile = Map.toList . fmap Set.toList . foldr insertMap Map.empty + insertMap ImportedSymbol{..} = + Map.insertWith Set.union impFile (Set.singleton impModule) + +formatWildcards :: WildcardImports -> Text +formatWildcards files = + "Modules in the following files were imported as wildcards:\n\n" + <> T.concat (fmap formatFile files) + where + formatFile (filepath, modules) = + "In " <> T.pack filepath <> ":\n" <> T.concat (fmap formatModule modules) <> "\n" + formatModule moduleName = " " <> moduleName <> "\n" + + +-- GRAPHS + +modulesGraph :: [ImportedSymbol] -> Dot.DotGraph +modulesGraph symbols = + Dot.DotGraph Dot.Strict Dot.Directed (Just "Modules") $ fmap edge edges + where + edge (from, to) = + Dot.StatementEdge $ Dot.EdgeStatement + (Dot.ListTwo (edgeNode from) (edgeNode to) mempty) mempty + edgeNode t = Dot.EdgeNode $ Dot.NodeId (Dot.Id t) Nothing + edges = unique . fmap edgeTuple . filter ((==) Internal . impInternal) $ symbols + edgeTuple ImportedSymbol{..} = (impFromModule, impModule) + unique = Set.toList . Set.fromList + +-- Building Text directly as the Dot package currently doesn't support subgraphs. +symbolsGraph :: [ImportedSymbol] -> Text +symbolsGraph symbols = + "digraph Symbols {\n" + <> " rankdir=LR\n" + <> " ranksep=5\n" + <> T.concat (fmap edge edges) + <> T.concat (fmap cluster symbolsByModule) + <> "}\n" + where + edge (from, to, symbol) = + " " + <> quoted from + <> " -> " + <> quoted (to <> maybe "" ("." <>) symbol) + <> "\n" + cluster (moduleName, clusterSymbols) = + " subgraph " + <> quoted ("cluster_" <> moduleName) + <> " {\n" + <> " " <> quoted moduleName <> "\n" + <> T.concat (fmap (clusterNode moduleName) clusterSymbols) + <> " }\n" + clusterNode moduleName symbol = + " " <> quoted (moduleName <> "." <> symbol) <> "\n" + quoted t = "\"" <> t <> "\"" + edges = unique . fmap edgeTuple . filter ((==) Internal . impInternal) $ symbols + edgeTuple ImportedSymbol{..} = (impFromModule, impModule, impSymbol) + unique = Set.toList . Set.fromList + symbolsByModule = + Map.toList . Map.map (catMaybes . Set.toList) . foldr insertMap Map.empty $ edges + insertMap (_, to, symbol) = Map.insertWith Set.union to $ Set.singleton symbol diff --git a/nix/hsie/README.md b/nix/hsie/README.md new file mode 100644 index 0000000000..f20b18dec1 --- /dev/null +++ b/nix/hsie/README.md @@ -0,0 +1,67 @@ +# hsie - Swiss army knife for HaSkell Imports and Exports + +This tool parses Haskell source code to analyse the imports and exports in a +project. It's available in PostgREST's `nix-shell` by default. + +## Dumping imports + +Given source code in the directories `src` and `main`, for example, you can run: + +``` +hsie dump-imports src main +``` + +This dumps all imports of the modules in the given directory to a CSV file, +printed on `stdout`. + +To dump to a JSON file (e.g., to further process with `jq`), add the `--json` +flag: + +``` +hsie dump-imports --json src main +``` + +## Graphing imports + +The tool can generate `graphviz` graphs of module and symbol imports by printing +a file to `stdout` that can directly be rendered with `dot`: + +``` +hsie graph-modules src main | dot -Tpng -o modules.png +``` + +The command `graph-modules` prints a graph of which modules insert which other +modules. `graph-symbols` shows which symbols are imported from which modules. + +## Checking imports + +To check whether modules are imported under consistent aliases in your project, +run: + +``` +hsie check-aliases main src +``` + +This will exit with a non-zero exit code if any inconsistent aliases are found. + +The following command checks whether any modules are imported as wildcards, i.e. +not qualified and without specifying symbols. + +``` +hsie check-wildcards main src +``` + +To whitelist certain modules to be imported as wildcards, use `--ok`: + +``` +hsie check-wildcards main src --ok Protolude --ok Test.Module +``` + +## Current limitations + +This tool uses the GHC parser to parse Haskell source code. Language extensions +required to parse each file are detected based on the `{-# LANGUAGE ... #-}` +pragmas. If they are not available (e.g., as they are listed as default +extensions in the `.cabal` file), parses may fail. We can fix this by using +an extended set of non-conflicting extensions by default, as `hlint` does for +example. diff --git a/nix/hsie/default.nix b/nix/hsie/default.nix new file mode 100644 index 0000000000..cb627dcaea --- /dev/null +++ b/nix/hsie/default.nix @@ -0,0 +1,30 @@ +{ ghcWithPackages +, runCommand +}: +let + name = "hsie"; + src = ./Main.hs; + modules = ps: [ + ps.aeson + ps.aeson-pretty + ps.cassava + ps.dir-traverse + ps.dot + ps.ghc-exactprint + ps.optparse-applicative + ]; + ghc = ghcWithPackages modules; + hsie = + runCommand "haskellimports" { inherit name src; } + "${ghc}/bin/ghc -O -Werror -Wall -package ghc $src -o $out"; + bin = + runCommand name { inherit hsie name; } + '' + mkdir -p $out/bin + ln -s $hsie $out/bin/$name + ''; + bashCompletion = + runCommand "${name}-bash-completion" { inherit bin name; } + "$bin/bin/$name --bash-completion-script $bin/bin/$name > $out"; +in +hsie // { inherit bashCompletion bin; } diff --git a/postgrest.cabal b/postgrest.cabal index e1b22c3b3b..02bf4b7b9c 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -32,7 +32,6 @@ flag hpc library default-language: Haskell2010 default-extensions: OverloadedStrings - QuasiQuotes NoImplicitPrelude hs-source-dirs: src exposed-modules: PostgREST.ApiRequest @@ -116,7 +115,6 @@ library executable postgrest default-language: Haskell2010 default-extensions: OverloadedStrings - QuasiQuotes NoImplicitPrelude hs-source-dirs: main main-is: Main.hs diff --git a/shell.nix b/shell.nix index 6952d54b0d..8af0a6e954 100644 --- a/shell.nix +++ b/shell.nix @@ -31,6 +31,7 @@ lib.overrideDerivation postgrest.env ( postgrest.devtools postgrest.tests postgrest.style + postgrest.hsie.bin ] ++ lib.optional memoryTests postgrest.tests.memoryTests ++ lib.optional docker postgrest.docker @@ -47,6 +48,7 @@ lib.overrideDerivation postgrest.env ( complete -F _command postgrest-with-postgresql-10 complete -F _command postgrest-with-postgresql-9.6 complete -F _command postgrest-with-postgresql-9.5 + source ${postgrest.hsie.bashCompletion} ''; } ) diff --git a/src/PostgREST/Config.hs b/src/PostgREST/Config.hs index dd9f162d95..e5956905c0 100644 --- a/src/PostgREST/Config.hs +++ b/src/PostgREST/Config.hs @@ -16,6 +16,7 @@ Other hardcoded options such as the minimum version number also belong here. {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} diff --git a/src/PostgREST/Private/QueryFragment.hs b/src/PostgREST/Private/QueryFragment.hs index c408fbfd84..839cc6ec0a 100644 --- a/src/PostgREST/Private/QueryFragment.hs +++ b/src/PostgREST/Private/QueryFragment.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE QuasiQuotes #-} {-| Module : PostgREST.Private.QueryFragment Description : Helper functions for PostgREST.QueryBuilder. diff --git a/src/PostgREST/Statements.hs b/src/PostgREST/Statements.hs index 9c2422db0d..ccf831fd69 100644 --- a/src/PostgREST/Statements.hs +++ b/src/PostgREST/Statements.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE QuasiQuotes #-} {-| Module : PostgREST.Statements Description : PostgREST single SQL statements.