From 4aab8614d28c969ccdbd9205f201f9cb29f730cc Mon Sep 17 00:00:00 2001 From: Connor James Date: Fri, 6 Mar 2020 11:44:20 -0800 Subject: [PATCH] Include project failures in the analysis blob (#40) --- hscli.cabal | 2 +- src/App/Scan.hs | 66 +++++++++++-- src/App/Scan/Graph.hs | 4 +- src/App/Scan/GraphBuilder.hs | 7 -- src/AppLicense/Scan.hs | 2 +- src/Control/Carrier/Output/IO.hs | 2 +- src/DepTypes.hs | 2 +- src/Effect/Exec.hs | 2 + src/Effect/ReadFS.hs | 8 +- src/Prologue.hs | 1 + src/Strategy/Carthage.hs | 12 +-- src/Strategy/Cocoapods/Podfile.hs | 14 ++- src/Strategy/Cocoapods/PodfileLock.hs | 96 +++++++++--------- src/Strategy/Go/GlideLock.hs | 18 ++-- src/Strategy/Go/GoList.hs | 20 ++-- src/Strategy/Go/Gomod.hs | 19 ++-- src/Strategy/Go/GopkgLock.hs | 19 ++-- src/Strategy/Go/GopkgToml.hs | 19 ++-- src/Strategy/Gradle.hs | 14 ++- src/Strategy/Maven/Plugin.hs | 4 +- src/Strategy/Maven/PluginStrategy.hs | 14 ++- src/Strategy/Maven/Pom/Resolver.hs | 3 +- src/Strategy/Node/NpmList.hs | 14 ++- src/Strategy/Node/NpmLock.hs | 14 ++- src/Strategy/Node/PackageJson.hs | 14 ++- src/Strategy/Node/YarnLock.hs | 14 ++- src/Strategy/NuGet/Nuspec.hs | 14 ++- src/Strategy/NuGet/PackageReference.hs | 14 ++- src/Strategy/NuGet/PackagesConfig.hs | 14 ++- src/Strategy/NuGet/Paket.hs | 14 ++- src/Strategy/NuGet/ProjectAssetsJson.hs | 14 ++- src/Strategy/NuGet/ProjectJson.hs | 14 ++- src/Strategy/Python/PipList.hs | 14 ++- src/Strategy/Python/Pipenv.hs | 14 ++- src/Strategy/Python/ReqTxt.hs | 14 ++- src/Strategy/Python/SetupPy.hs | 14 ++- src/Strategy/Ruby/BundleShow.hs | 14 ++- src/Strategy/Ruby/GemfileLock.hs | 126 +++++++++++------------- src/Types.hs | 63 +++++++----- test/Cocoapods/PodfileLockTest.hs | 6 +- test/Go/GoListTest.hs | 4 +- 41 files changed, 373 insertions(+), 384 deletions(-) diff --git a/hscli.cabal b/hscli.cabal index 0b65fcfcb..10acbdf64 100644 --- a/hscli.cabal +++ b/hscli.cabal @@ -56,7 +56,7 @@ common deps , containers ^>=0.6.0 , file-embed ^>=0.0.11 , filepath ^>=1.4.2.1 - , fused-effects ^>=1.0.0.1 + , fused-effects ^>=1.0.2.0 , fused-effects-exceptions ^>=1.0.0.0 , git-config ^>=0.1.2 , megaparsec ^>=8.0 diff --git a/src/App/Scan.hs b/src/App/Scan.hs index a6b6550d3..7d8fd7d89 100644 --- a/src/App/Scan.hs +++ b/src/App/Scan.hs @@ -22,7 +22,9 @@ import Control.Carrier.Threaded import qualified Data.ByteString.Lazy as BL import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Render.Terminal +import Effect.Exec (ExecErr(..)) import Effect.Logger +import Effect.ReadFS (ReadFSErr(..)) import qualified Strategy.Carthage as Carthage import qualified Strategy.Cocoapods.Podfile as Podfile import qualified Strategy.Cocoapods.PodfileLock as PodfileLock @@ -44,7 +46,6 @@ import qualified Strategy.NuGet.ProjectAssetsJson as ProjectAssetsJson import qualified Strategy.NuGet.ProjectJson as ProjectJson import qualified Strategy.NuGet.Nuspec as Nuspec import qualified Strategy.Python.Pipenv as Pipenv -import qualified Strategy.Python.PipList as PipList import qualified Strategy.Python.ReqTxt as ReqTxt import qualified Strategy.Python.SetupPy as SetupPy import qualified Strategy.Ruby.BundleShow as BundleShow @@ -88,15 +89,15 @@ scan basedir outFile = do setCurrentDir basedir capabilities <- liftIO getNumCapabilities - (closures,()) <- runOutput @ProjectClosure $ + (closures,(failures,())) <- runOutput @ProjectClosure $ runOutput @ProjectFailure $ withTaskPool capabilities updateProgress (traverse_ ($ basedir) discoverFuncs) logSticky "[ Combining Analyses ]" - let projects = mkProjects (S.fromList closures) + let result = buildResult closures failures liftIO $ case outFile of - Nothing -> BL.putStr (encode projects) - Just path -> liftIO (encodeFile path projects) + Nothing -> BL.putStr (encode result) + Just path -> liftIO (encodeFile path result) inferred <- inferProject basedir logInfo "" @@ -105,6 +106,60 @@ scan basedir outFile = do logSticky "" +buildResult :: [ProjectClosure] -> [ProjectFailure] -> Value +buildResult closures failures = object + [ "projects" .= mkProjects (S.fromList closures) + , "failures" .= map renderFailure failures + ] + +renderFailure :: ProjectFailure -> Value +renderFailure failure = object + [ "name" .= projectFailureName failure + , "cause" .= renderCause (projectFailureCause failure) + ] + +renderCause :: SomeException -> Value +renderCause e = fromMaybe renderSomeException $ + renderReadFSErr <$> fromException e + <|> renderExecErr <$> fromException e + where + renderSomeException = object + [ "type" .= ("unknown" :: Text) + , "err" .= show e + ] + + renderReadFSErr :: ReadFSErr -> Value + renderReadFSErr = \case + FileReadError path err -> object + [ "type" .= ("file_read_error" :: Text) + , "path" .= path + , "err" .= err + ] + FileParseError path err -> object + [ "type" .= ("file_parse_error" :: Text) + , "path" .= path + , "err" .= err + ] + ResolveError base path err -> object + [ "type" .= ("file_resolve_error" :: Text) + , "base" .= base + , "path" .= path + , "err" .= err + ] + + renderExecErr :: ExecErr -> Value + renderExecErr = \case + CommandFailed cmd outerr -> object + [ "type" .= ("command_execution_error" :: Text) + , "cmd" .= cmd + , "stderr" .= outerr + ] + CommandParseError cmd err -> object + [ "type" .= ("command_parse_error" :: Text) + , "cmd" .= cmd + , "err" .= err + ] + discoverFuncs :: HasDiscover sig m => [Path Abs Dir -> m ()] discoverFuncs = [ GoList.discover @@ -129,7 +184,6 @@ discoverFuncs = , ProjectJson.discover , Nuspec.discover - , PipList.discover , Pipenv.discover , SetupPy.discover , ReqTxt.discover diff --git a/src/App/Scan/Graph.hs b/src/App/Scan/Graph.hs index 2e420edf8..9cfb4fdf2 100644 --- a/src/App/Scan/Graph.hs +++ b/src/App/Scan/Graph.hs @@ -49,8 +49,8 @@ empty :: Graph empty = Graph S.empty IM.empty IS.empty -- | Add a new dependency node to the graph. The returned 'DepRef' can be used to 'addEdge's -addNode :: Dependency -> Graph -> (DepRef, Graph) -addNode dep graph = (DepRef (length curDeps), graph { _graphDeps = curDeps S.|> dep }) +addNode :: Dependency -> Graph -> (Graph, DepRef) +addNode dep graph = (graph { _graphDeps = curDeps S.|> dep }, DepRef (length curDeps)) where curDeps = _graphDeps graph diff --git a/src/App/Scan/GraphBuilder.hs b/src/App/Scan/GraphBuilder.hs index fa859429a..9ba6731d6 100644 --- a/src/App/Scan/GraphBuilder.hs +++ b/src/App/Scan/GraphBuilder.hs @@ -53,10 +53,3 @@ instance (Algebra sig m, Effect sig) => Algebra (GraphBuilder :+: sig) (GraphBui AddNode dep k -> GraphBuilderC (state (G.addNode dep)) >>= k AddEdge parent child k -> GraphBuilderC (modify (G.addEdge parent child)) *> k AddDirect dep k -> GraphBuilderC (modify (G.addDirect dep)) *> k - -state :: Has (State s) sig m => (s -> (a,s)) -> m a -state f = do - before <- get - let (result, after) = f before - result <$ put after - diff --git a/src/AppLicense/Scan.hs b/src/AppLicense/Scan.hs index 55e21ed8d..b0ceefbf3 100644 --- a/src/AppLicense/Scan.hs +++ b/src/AppLicense/Scan.hs @@ -46,7 +46,7 @@ scan basedir = do setCurrentDir basedir capabilities <- liftIO getNumCapabilities - (closures,()) <- runOutput @ProjectClosure $ + (closures,(_,())) <- runOutput @ProjectClosure $ runOutput @ProjectFailure $ withTaskPool capabilities updateProgress (traverse_ ($ basedir) discoverFuncs) logSticky "[ Combining Analyses ]" diff --git a/src/Control/Carrier/Output/IO.hs b/src/Control/Carrier/Output/IO.hs index 318f09d8f..11dde09c1 100644 --- a/src/Control/Carrier/Output/IO.hs +++ b/src/Control/Carrier/Output/IO.hs @@ -17,7 +17,7 @@ runOutput act = do pure (outputs, res) newtype OutputC o m a = OutputC { runOutputC :: ReaderC (IORef [o]) m a } - deriving (Functor, Applicative, Monad, MonadIO) + deriving (Functor, Applicative, Monad, MonadIO, MonadTrans) instance (Algebra sig m, MonadIO m) => Algebra (Output o :+: sig) (OutputC o m) where alg (L (Output o k)) = do diff --git a/src/DepTypes.hs b/src/DepTypes.hs index 6fce29e9f..1c7dcb1c5 100644 --- a/src/DepTypes.hs +++ b/src/DepTypes.hs @@ -69,7 +69,7 @@ instance ToJSON VerConstraint where CAnd a b -> ("AND", toJSON [toJSON a, toJSON b]) COr a b -> ("OR", toJSON [toJSON a, toJSON b]) CLess text -> ("LESSTHAN", toJSON text) - CLessOrEq text -> ("LESSTHANOREQUAL", toJSON text) + CLessOrEq text -> ("LESSOREQUAL", toJSON text) CGreater text -> ("GREATERTHAN", toJSON text) CGreaterOrEq text -> ("GREATEROREQUAL", toJSON text) CNot text -> ("NOT", toJSON text) diff --git a/src/Effect/Exec.hs b/src/Effect/Exec.hs index 44114aa05..4bdb4dd7c 100644 --- a/src/Effect/Exec.hs +++ b/src/Effect/Exec.hs @@ -66,6 +66,8 @@ data ExecErr = | CommandParseError Text Text -- ^ Command output couldn't be parsed. command, err deriving (Eq, Ord, Show, Generic, Typeable) +instance Exc.Exception ExecErr + instance HFunctor Exec where hmap f (Exec dir cmd args k) = Exec dir cmd args (f . k) diff --git a/src/Effect/ReadFS.hs b/src/Effect/ReadFS.hs index f5ad7fda2..63e688ca7 100644 --- a/src/Effect/ReadFS.hs +++ b/src/Effect/ReadFS.hs @@ -58,9 +58,11 @@ data ReadFS m k data ReadFSErr = FileReadError FilePath Text -- ^ A file couldn't be read. file, err | FileParseError FilePath Text -- ^ A file's contents couldn't be parsed. TODO: ask user to help with this. file, err - | ResolveError Text -- ^ An IOException was thrown when resolving a file/directory + | ResolveError FilePath FilePath Text -- ^ An IOException was thrown when resolving a file/directory deriving (Eq, Ord, Show, Generic, Typeable) +instance E.Exception ReadFSErr + instance HFunctor ReadFS where hmap f = \case ReadContentsBS' path k -> ReadContentsBS' path (f . k) @@ -188,11 +190,11 @@ instance (Algebra sig m, MonadIO m) => Algebra (ReadFS :+: sig) (ReadFSIOC m) wh ResolveFile' dir path k -> (k =<<) . ReadFSIOC $ liftIO $ (Right <$> PIO.resolveFile dir (T.unpack path)) `E.catch` - (\(e :: E.IOException) -> pure (Left (ResolveError (T.pack (show e))))) + (\(e :: E.IOException) -> pure (Left (ResolveError (toFilePath dir) (T.unpack path) (T.pack (show e))))) ResolveDir' dir path k -> (k =<<) . ReadFSIOC $ liftIO $ (Right <$> PIO.resolveDir dir (T.unpack path)) `E.catch` - (\(e :: E.IOException) -> pure (Left (ResolveError (T.pack (show e))))) + (\(e :: E.IOException) -> pure (Left (ResolveError (toFilePath dir) (T.unpack path) (T.pack (show e))))) -- NB: these never throw DoesFileExist file k -> k =<< PIO.doesFileExist file DoesDirExist dir k -> k =<< PIO.doesDirExist dir diff --git a/src/Prologue.hs b/src/Prologue.hs index 7b02577d2..27aa677ea 100644 --- a/src/Prologue.hs +++ b/src/Prologue.hs @@ -13,6 +13,7 @@ import Debug.Trace as X (traceM, traceShow, traceShowId) import Control.Applicative as X hiding (many, some) import Control.Monad as X import Control.Monad.IO.Class as X +import Control.Monad.Trans as X import Control.Effect.Error import Data.Aeson as X hiding (Error) import Data.Bifunctor as X diff --git a/src/Strategy/Carthage.hs b/src/Strategy/Carthage.hs index 095d4b042..49736c65f 100644 --- a/src/Strategy/Carthage.hs +++ b/src/Strategy/Carthage.hs @@ -33,13 +33,11 @@ discover = walk $ \_ subdirs files -> runSimpleStrategy "carthage-lock" CarthageGroup $ fmap (mkProjectClosure file) (analyze file) walkSkipAll subdirs -mkProjectClosure :: Path Rel File -> G.Graphing ResolvedEntry -> ProjectClosure -mkProjectClosure file graph = ProjectClosure - { closureStrategyGroup = CarthageGroup - , closureStrategyName = "carthage-lock" - , closureModuleDir = parent file - , closureDependencies = dependencies - , closureLicenses = [] +mkProjectClosure :: Path Rel File -> G.Graphing ResolvedEntry -> ProjectClosureBody +mkProjectClosure file graph = ProjectClosureBody + { bodyModuleDir = parent file + , bodyDependencies = dependencies + , bodyLicenses = [] } where dependencies = ProjectDependencies diff --git a/src/Strategy/Cocoapods/Podfile.hs b/src/Strategy/Cocoapods/Podfile.hs index 7ba539863..608f15d7d 100644 --- a/src/Strategy/Cocoapods/Podfile.hs +++ b/src/Strategy/Cocoapods/Podfile.hs @@ -32,16 +32,14 @@ discover = walk $ \_ _ files -> do walkContinue -analyze :: (Has ReadFS sig m, Has (Error ReadFSErr) sig m) => Path Rel File -> m ProjectClosure +analyze :: (Has ReadFS sig m, Has (Error ReadFSErr) sig m) => Path Rel File -> m ProjectClosureBody analyze file = mkProjectClosure file <$> readContentsParser parsePodfile file -mkProjectClosure :: Path Rel File -> Podfile -> ProjectClosure -mkProjectClosure file podfile = ProjectClosure - { closureStrategyGroup = CocoapodsGroup - , closureStrategyName = "cocoapods-podfilelock" - , closureModuleDir = parent file - , closureDependencies = dependencies - , closureLicenses = [] +mkProjectClosure :: Path Rel File -> Podfile -> ProjectClosureBody +mkProjectClosure file podfile = ProjectClosureBody + { bodyModuleDir = parent file + , bodyDependencies = dependencies + , bodyLicenses = [] } where dependencies = ProjectDependencies diff --git a/src/Strategy/Cocoapods/PodfileLock.hs b/src/Strategy/Cocoapods/PodfileLock.hs index 5abd64bc1..f1452c8f6 100644 --- a/src/Strategy/Cocoapods/PodfileLock.hs +++ b/src/Strategy/Cocoapods/PodfileLock.hs @@ -35,16 +35,14 @@ discover = walk $ \_ _ files -> do walkContinue -analyze :: (Has ReadFS sig m, Has (Error ReadFSErr) sig m) => Path Rel File -> m ProjectClosure +analyze :: (Has ReadFS sig m, Has (Error ReadFSErr) sig m) => Path Rel File -> m ProjectClosureBody analyze file = mkProjectClosure file <$> readContentsParser findSections file -mkProjectClosure :: Path Rel File -> [Section] -> ProjectClosure -mkProjectClosure file sections = ProjectClosure - { closureStrategyGroup = CocoapodsGroup - , closureStrategyName = "cocoapods-podfilelock" - , closureModuleDir = parent file - , closureDependencies = dependencies - , closureLicenses = [] +mkProjectClosure :: Path Rel File -> [Section] -> ProjectClosureBody +mkProjectClosure file sections = ProjectClosureBody + { bodyModuleDir = parent file + , bodyDependencies = dependencies + , bodyLicenses = [] } where dependencies = ProjectDependencies @@ -127,13 +125,13 @@ data Remote = Remote } deriving (Eq, Ord, Show, Generic) findSections :: Parser [Section] -findSections = many (try podSectionParser <|> try dependenciesSectionParser <|> try specRepoParser <|> try externalSourcesParser <|> try checkoutOptionsParser <|> try emptySection) <* eof +findSections = manyTill (try podSectionParser <|> try dependenciesSectionParser <|> try specRepoParser <|> try externalSourcesParser <|> try checkoutOptionsParser <|> unknownSection) eof -emptySection :: Parser Section -emptySection = do - emptyLine <- restOfLine - _ <- eol - pure $ UnknownSection emptyLine +unknownSection :: Parser Section +unknownSection = do + scn + line <- restOfLine + pure $ UnknownSection line podSectionParser :: Parser Section podSectionParser = sectionParser "PODS:" PodSection podParser @@ -151,61 +149,49 @@ checkoutOptionsParser :: Parser Section checkoutOptionsParser = sectionParser "CHECKOUT OPTIONS:" CheckoutOptions externalDepsParser sectionParser :: Text -> ([a] -> Section) -> Parser a -> Parser Section -sectionParser section lambda parser = L.nonIndented scn (L.indentBlock scn p) - where - p = do - _ <- chunk section - return (L.IndentMany Nothing (pure . lambda) parser) +sectionParser sectionName lambda parser = nonIndented $ indentBlock $ do + _ <- chunk sectionName + return (L.IndentMany Nothing (pure . lambda) parser) externalDepsParser :: Parser SourceDep -externalDepsParser = L.indentBlock scn p - where - p = do - depName <- lexeme (takeWhileP (Just "external dep parser") (/= ':')) - _ <- restOfLine - return (L.IndentMany Nothing (\exDeps -> pure $ SourceDep depName $ M.fromList exDeps) tagParser) +externalDepsParser = indentBlock $ do + depName <- lexeme (takeWhileP (Just "external dep parser") (/= ':')) + _ <- restOfLine + return (L.IndentMany Nothing (\exDeps -> pure $ SourceDep depName $ M.fromList exDeps) tagParser) tagParser :: Parser (Text, Text) tagParser = do - _ <- chunk ":" - tag <- lexeme (takeWhileP (Just "tag parser") (/= ':')) - _ <- chunk ": " - value <- restOfLine - pure (tag, value) + _ <- chunk ":" + tag <- lexeme (takeWhileP (Just "tag parser") (/= ':')) + _ <- chunk ": " + value <- restOfLine + pure (tag, value) remoteParser :: Parser Remote -remoteParser = L.indentBlock scn p - where - p = do - location <- restOfLine - pure (L.IndentMany Nothing (\deps -> pure $ Remote (T.dropWhileEnd (==':') location) deps) depParser) +remoteParser = indentBlock $ do + location <- restOfLine + pure (L.IndentMany Nothing (\deps -> pure $ Remote (T.dropWhileEnd (==':') location) deps) depParser) podParser :: Parser Pod -podParser = L.indentBlock scn p - where - p = do - _ <- chunk "- " - name <- findDep - version <- findVersion - _ <- restOfLine - pure (L.IndentMany Nothing (\deps -> pure $ Pod name version deps) depParser) +podParser = indentBlock $ do + _ <- chunk "- " + name <- findDep + version <- findVersion + _ <- restOfLine + pure (L.IndentMany Nothing (\deps -> pure $ Pod name version deps) depParser) depParser :: Parser Dep depParser = do - _ <- chunk "- " - name <- findDep - _ <- restOfLine - pure $ Dep name + _ <- chunk "- " + name <- findDep + _ <- restOfLine + pure $ Dep name findDep :: Parser Text findDep = lexeme (takeWhile1P (Just "dep") (not . C.isSpace)) findVersion :: Parser Text -findVersion = do - _ <- char '(' - result <- lexeme (takeWhileP (Just "version") (/= ')')) - _ <- char ')' - pure result +findVersion = between (char '(') (char ')') (lexeme (takeWhileP (Just "version") (/= ')'))) restOfLine :: Parser Text restOfLine = takeWhileP (Just "ignored") (not . isEndLine) @@ -215,6 +201,12 @@ isEndLine '\n' = True isEndLine '\r' = True isEndLine _ = False +nonIndented :: Parser a -> Parser a +nonIndented = L.nonIndented scn + +indentBlock :: Parser (L.IndentOpt Parser a b) -> Parser a +indentBlock = L.indentBlock scn + scn :: Parser () scn = L.space space1 empty empty diff --git a/src/Strategy/Go/GlideLock.hs b/src/Strategy/Go/GlideLock.hs index 442f63d6f..9ad8593b9 100644 --- a/src/Strategy/Go/GlideLock.hs +++ b/src/Strategy/Go/GlideLock.hs @@ -28,20 +28,14 @@ discover = walk $ \_ _ files -> do walkContinue -analyze :: - ( Has ReadFS sig m - , Has (Error ReadFSErr) sig m - ) - => Path Rel File -> m ProjectClosure +analyze :: ( Has ReadFS sig m , Has (Error ReadFSErr) sig m) => Path Rel File -> m ProjectClosureBody analyze file = mkProjectClosure file <$> readContentsYaml @GlideLockfile file -mkProjectClosure :: Path Rel File -> GlideLockfile -> ProjectClosure -mkProjectClosure file lock = ProjectClosure - { closureStrategyGroup = GolangGroup - , closureStrategyName = "golang-glidelock" - , closureModuleDir = parent file - , closureDependencies = dependencies - , closureLicenses = [] +mkProjectClosure :: Path Rel File -> GlideLockfile -> ProjectClosureBody +mkProjectClosure file lock = ProjectClosureBody + { bodyModuleDir = parent file + , bodyDependencies = dependencies + , bodyLicenses = [] } where dependencies = ProjectDependencies diff --git a/src/Strategy/Go/GoList.hs b/src/Strategy/Go/GoList.hs index 30662b715..0873e7bc8 100644 --- a/src/Strategy/Go/GoList.hs +++ b/src/Strategy/Go/GoList.hs @@ -18,7 +18,6 @@ import Discovery.Walk import Effect.Exec import Effect.LabeledGrapher import Graphing (Graphing) -import Strategy.Go.Transitive (fillInTransitive) import Strategy.Go.Types import Types @@ -47,7 +46,7 @@ analyze :: , Has (Error ExecErr) sig m , Effect sig ) - => Path Rel Dir -> m ProjectClosure + => Path Rel Dir -> m ProjectClosureBody analyze dir = fmap (mkProjectClosure dir) . graphingGolang $ do stdout <- execThrow dir golistCmd [] @@ -63,19 +62,14 @@ analyze dir = fmap (mkProjectClosure dir) . graphingGolang $ do buildGraph requires -- TODO: diagnostics? - _ <- try @ExecErr (fillInTransitive dir) + -- _ <- try @ExecErr (fillInTransitive dir) pure () -try :: Has (Error e) sig m => m a -> m (Either e a) -try act = (Right <$> act) `catchError` (pure . Left) - -mkProjectClosure :: Path Rel Dir -> Graphing Dependency -> ProjectClosure -mkProjectClosure dir graph = ProjectClosure - { closureStrategyGroup = GolangGroup - , closureStrategyName = "golang-golist" - , closureModuleDir = dir - , closureDependencies = dependencies - , closureLicenses = [] +mkProjectClosure :: Path Rel Dir -> Graphing Dependency -> ProjectClosureBody +mkProjectClosure dir graph = ProjectClosureBody + { bodyModuleDir = dir + , bodyDependencies = dependencies + , bodyLicenses = [] } where dependencies = ProjectDependencies diff --git a/src/Strategy/Go/Gomod.hs b/src/Strategy/Go/Gomod.hs index e138ced98..466ad6bb2 100644 --- a/src/Strategy/Go/Gomod.hs +++ b/src/Strategy/Go/Gomod.hs @@ -21,11 +21,9 @@ import qualified Text.Megaparsec.Char.Lexer as L import DepTypes import Discovery.Walk -import Effect.Exec import Effect.LabeledGrapher import Effect.ReadFS import Graphing (Graphing) -import Strategy.Go.Transitive import Strategy.Go.Types import Types @@ -178,26 +176,23 @@ resolve gomod = map resolveReplace (modRequires gomod) analyze :: ( Has ReadFS sig m , Has (Error ReadFSErr) sig m - , Has Exec sig m , Effect sig ) - => Path Rel File -> m ProjectClosure + => Path Rel File -> m ProjectClosureBody analyze file = fmap (mkProjectClosure file) . graphingGolang $ do gomod <- readContentsParser gomodParser file buildGraph gomod -- TODO: diagnostics? - _ <- runError @ExecErr (fillInTransitive (parent file)) + -- _ <- runError @ExecErr (fillInTransitive (parent file)) pure () -mkProjectClosure :: Path Rel File -> Graphing Dependency -> ProjectClosure -mkProjectClosure file graph = ProjectClosure - { closureStrategyGroup = GolangGroup - , closureStrategyName = "golang-gomod" - , closureModuleDir = parent file - , closureDependencies = dependencies - , closureLicenses = [] +mkProjectClosure :: Path Rel File -> Graphing Dependency -> ProjectClosureBody +mkProjectClosure file graph = ProjectClosureBody + { bodyModuleDir = parent file + , bodyDependencies = dependencies + , bodyLicenses = [] } where dependencies = ProjectDependencies diff --git a/src/Strategy/Go/GopkgLock.hs b/src/Strategy/Go/GopkgLock.hs index 7961b1fa3..c40d85e36 100644 --- a/src/Strategy/Go/GopkgLock.hs +++ b/src/Strategy/Go/GopkgLock.hs @@ -15,11 +15,9 @@ import Prologue hiding ((.=)) import Control.Carrier.Error.Either import DepTypes import Discovery.Walk -import Effect.Exec import Effect.LabeledGrapher import Effect.ReadFS import Graphing (Graphing) -import Strategy.Go.Transitive (fillInTransitive) import Strategy.Go.Types import qualified Toml import Toml (TomlCodec, (.=)) @@ -56,10 +54,9 @@ data Project = Project analyze :: ( Has ReadFS sig m , Has (Error ReadFSErr) sig m - , Has Exec sig m , Effect sig ) - => Path Rel File -> m ProjectClosure + => Path Rel File -> m ProjectClosureBody analyze file = fmap (mkProjectClosure file) . graphingGolang $ do contents <- readContentsText file case Toml.decode golockCodec contents of @@ -68,16 +65,14 @@ analyze file = fmap (mkProjectClosure file) . graphingGolang $ do buildGraph (lockProjects golock) -- TODO: diagnostics? - _ <- runError @ExecErr (fillInTransitive (parent file)) + -- _ <- runError @ExecErr (fillInTransitive (parent file)) pure () -mkProjectClosure :: Path Rel File -> Graphing Dependency -> ProjectClosure -mkProjectClosure file graph = ProjectClosure - { closureStrategyGroup = GolangGroup - , closureStrategyName = "golang-gopkglock" - , closureModuleDir = parent file - , closureDependencies = dependencies - , closureLicenses = [] +mkProjectClosure :: Path Rel File -> Graphing Dependency -> ProjectClosureBody +mkProjectClosure file graph = ProjectClosureBody + { bodyModuleDir = parent file + , bodyDependencies = dependencies + , bodyLicenses = [] } where dependencies = ProjectDependencies diff --git a/src/Strategy/Go/GopkgToml.hs b/src/Strategy/Go/GopkgToml.hs index 408f320a6..d4ef5899b 100644 --- a/src/Strategy/Go/GopkgToml.hs +++ b/src/Strategy/Go/GopkgToml.hs @@ -20,11 +20,9 @@ import qualified Toml import DepTypes import Discovery.Walk -import Effect.Exec import Effect.LabeledGrapher import Effect.ReadFS import Graphing (Graphing) -import Strategy.Go.Transitive (fillInTransitive) import Strategy.Go.Types import Types @@ -66,10 +64,9 @@ data PkgConstraint = PkgConstraint analyze :: ( Has ReadFS sig m , Has (Error ReadFSErr) sig m - , Has Exec sig m , Effect sig ) - => Path Rel File -> m ProjectClosure + => Path Rel File -> m ProjectClosureBody analyze file = fmap (mkProjectClosure file) . graphingGolang $ do contents <- readContentsText file case Toml.decode gopkgCodec contents of @@ -78,16 +75,14 @@ analyze file = fmap (mkProjectClosure file) . graphingGolang $ do buildGraph gopkg -- TODO: diagnostics? - _ <- runError @ExecErr (fillInTransitive (parent file)) + -- _ <- runError @ExecErr (fillInTransitive (parent file)) pure () -mkProjectClosure :: Path Rel File -> Graphing Dependency -> ProjectClosure -mkProjectClosure file graph = ProjectClosure - { closureStrategyGroup = GolangGroup - , closureStrategyName = "golang-gopkgtoml" - , closureModuleDir = parent file - , closureDependencies = dependencies - , closureLicenses = [] +mkProjectClosure :: Path Rel File -> Graphing Dependency -> ProjectClosureBody +mkProjectClosure file graph = ProjectClosureBody + { bodyModuleDir = parent file + , bodyDependencies = dependencies + , bodyLicenses = [] } where dependencies = ProjectDependencies diff --git a/src/Strategy/Gradle.hs b/src/Strategy/Gradle.hs index 85f04dafa..6334c0dc5 100644 --- a/src/Strategy/Gradle.hs +++ b/src/Strategy/Gradle.hs @@ -53,7 +53,7 @@ analyze :: , Has (Error ExecErr) sig m , MonadIO m ) - => Path Rel Dir -> m ProjectClosure + => Path Rel Dir -> m ProjectClosureBody analyze dir = bracket (liftIO (getTempDir >>= \tmp -> createTempDir tmp "fossa-gradle")) (liftIO . removeDirRecur) @@ -87,13 +87,11 @@ analyze dir = pure (mkProjectClosure dir packagesToOutput) -mkProjectClosure :: Path Rel Dir -> Map Text [JsonDep] -> ProjectClosure -mkProjectClosure dir deps = ProjectClosure - { closureStrategyGroup = GradleGroup - , closureStrategyName = "gradle-cli" - , closureModuleDir = dir - , closureDependencies = dependencies - , closureLicenses = [] +mkProjectClosure :: Path Rel Dir -> Map Text [JsonDep] -> ProjectClosureBody +mkProjectClosure dir deps = ProjectClosureBody + { bodyModuleDir = dir + , bodyDependencies = dependencies + , bodyLicenses = [] } where dependencies = ProjectDependencies diff --git a/src/Strategy/Maven/Plugin.hs b/src/Strategy/Maven/Plugin.hs index 781142896..0f1d0dcb7 100644 --- a/src/Strategy/Maven/Plugin.hs +++ b/src/Strategy/Maven/Plugin.hs @@ -116,8 +116,8 @@ data Edge = Edge instance FromJSON PluginOutput where parseJSON = withObject "PluginOutput" $ \obj -> - PluginOutput <$> obj .: "artifacts" - <*> obj .: "dependencies" + PluginOutput <$> obj .:? "artifacts" .!= [] + <*> obj .:? "dependencies" .!= [] instance FromJSON Artifact where parseJSON = withObject "Artifact" $ \obj -> diff --git a/src/Strategy/Maven/PluginStrategy.hs b/src/Strategy/Maven/PluginStrategy.hs index b76998cb8..ff6dfb305 100644 --- a/src/Strategy/Maven/PluginStrategy.hs +++ b/src/Strategy/Maven/PluginStrategy.hs @@ -34,20 +34,18 @@ analyze :: , Has (Error ExecErr) sig m , MonadIO m ) - => Path Rel Dir -> m ProjectClosure + => Path Rel Dir -> m ProjectClosureBody analyze dir = withUnpackedPlugin $ \filepath -> do installPlugin dir filepath execPlugin dir pluginOutput <- parsePluginOutput dir pure (mkProjectClosure dir pluginOutput) -mkProjectClosure :: Path Rel Dir -> PluginOutput -> ProjectClosure -mkProjectClosure dir pluginOutput = ProjectClosure - { closureStrategyGroup = MavenGroup - , closureStrategyName = "maven-cli" - , closureModuleDir = dir - , closureDependencies = dependencies - , closureLicenses = [] +mkProjectClosure :: Path Rel Dir -> PluginOutput -> ProjectClosureBody +mkProjectClosure dir pluginOutput = ProjectClosureBody + { bodyModuleDir = dir + , bodyDependencies = dependencies + , bodyLicenses = [] } where dependencies = ProjectDependencies diff --git a/src/Strategy/Maven/Pom/Resolver.hs b/src/Strategy/Maven/Pom/Resolver.hs index fa9022021..33b6efc7b 100644 --- a/src/Strategy/Maven/Pom/Resolver.hs +++ b/src/Strategy/Maven/Pom/Resolver.hs @@ -12,7 +12,6 @@ import Control.Algebra import Control.Carrier.Error.Either import Control.Carrier.State.Strict import qualified Data.Map.Strict as M -import qualified Data.Text as T import Effect.ReadFS import Strategy.Maven.Pom.PomFile @@ -112,7 +111,7 @@ resolvePath cur txt = do checkFile file = do exists <- doesFileExist file unless exists $ - throwError (ResolveError $ "resolvePath: resolved file does not exist: " <> T.pack (show file)) + throwError (FileReadError (show file) "resolvePath: resolved file does not exist: ") pure file resolveToFile `catchError` (\(_ :: ReadFSErr) -> resolveToDir) diff --git a/src/Strategy/Node/NpmList.hs b/src/Strategy/Node/NpmList.hs index 1948e017a..8e5bd1c6b 100644 --- a/src/Strategy/Node/NpmList.hs +++ b/src/Strategy/Node/NpmList.hs @@ -28,16 +28,14 @@ npmListCmd = Command , cmdAllowErr = NonEmptyStdout } -analyze :: (Has Exec sig m, Has (Error ExecErr) sig m) => Path Rel Dir -> m ProjectClosure +analyze :: (Has Exec sig m, Has (Error ExecErr) sig m) => Path Rel Dir -> m ProjectClosureBody analyze dir = mkProjectClosure dir <$> execJson @NpmOutput dir npmListCmd [] -mkProjectClosure :: Path Rel Dir -> NpmOutput -> ProjectClosure -mkProjectClosure dir npmOutput = ProjectClosure - { closureStrategyGroup = NodejsGroup - , closureStrategyName = "nodejs-npmlist" - , closureModuleDir = dir - , closureDependencies = dependencies - , closureLicenses = [] +mkProjectClosure :: Path Rel Dir -> NpmOutput -> ProjectClosureBody +mkProjectClosure dir npmOutput = ProjectClosureBody + { bodyModuleDir = dir + , bodyDependencies = dependencies + , bodyLicenses = [] } where dependencies = ProjectDependencies diff --git a/src/Strategy/Node/NpmLock.hs b/src/Strategy/Node/NpmLock.hs index 64aa17ac5..b5d60844e 100644 --- a/src/Strategy/Node/NpmLock.hs +++ b/src/Strategy/Node/NpmLock.hs @@ -55,16 +55,14 @@ instance FromJSON NpmDep where <*> obj .:? "requires" <*> obj .:? "dependencies" -analyze :: (Has ReadFS sig m, Has (Error ReadFSErr) sig m) => Path Rel File -> m ProjectClosure +analyze :: (Has ReadFS sig m, Has (Error ReadFSErr) sig m) => Path Rel File -> m ProjectClosureBody analyze file = mkProjectClosure file <$> readContentsJson @NpmPackageJson file -mkProjectClosure :: Path Rel File -> NpmPackageJson -> ProjectClosure -mkProjectClosure file lock = ProjectClosure - { closureStrategyGroup = NodejsGroup - , closureStrategyName = "nodejs-packagelock" - , closureModuleDir = parent file - , closureDependencies = dependencies - , closureLicenses = [] +mkProjectClosure :: Path Rel File -> NpmPackageJson -> ProjectClosureBody +mkProjectClosure file lock = ProjectClosureBody + { bodyModuleDir = parent file + , bodyDependencies = dependencies + , bodyLicenses = [] } where dependencies = ProjectDependencies diff --git a/src/Strategy/Node/PackageJson.hs b/src/Strategy/Node/PackageJson.hs index 2f95c2ab6..b9f4c58ac 100644 --- a/src/Strategy/Node/PackageJson.hs +++ b/src/Strategy/Node/PackageJson.hs @@ -34,16 +34,14 @@ instance FromJSON PackageJson where PackageJson <$> obj .:? "dependencies" .!= M.empty <*> obj .:? "devDependencies" .!= M.empty -analyze :: (Has ReadFS sig m, Has (Error ReadFSErr) sig m) => Path Rel File -> m ProjectClosure +analyze :: (Has ReadFS sig m, Has (Error ReadFSErr) sig m) => Path Rel File -> m ProjectClosureBody analyze file = mkProjectClosure file <$> readContentsJson @PackageJson file -mkProjectClosure :: Path Rel File -> PackageJson -> ProjectClosure -mkProjectClosure file package = ProjectClosure - { closureStrategyGroup = NodejsGroup - , closureStrategyName = "nodejs-packagejson" - , closureModuleDir = parent file - , closureDependencies = dependencies - , closureLicenses = [] +mkProjectClosure :: Path Rel File -> PackageJson -> ProjectClosureBody +mkProjectClosure file package = ProjectClosureBody + { bodyModuleDir = parent file + , bodyDependencies = dependencies + , bodyLicenses = [] } where dependencies = ProjectDependencies diff --git a/src/Strategy/Node/YarnLock.hs b/src/Strategy/Node/YarnLock.hs index 1ad91cf8d..681e87b80 100644 --- a/src/Strategy/Node/YarnLock.hs +++ b/src/Strategy/Node/YarnLock.hs @@ -27,7 +27,7 @@ discover = walk $ \_ subdirs files -> do walkSkipNamed ["node_modules/"] subdirs -analyze :: (Has ReadFS sig m, Has (Error ReadFSErr) sig m) => Path Rel File -> m ProjectClosure +analyze :: (Has ReadFS sig m, Has (Error ReadFSErr) sig m) => Path Rel File -> m ProjectClosureBody analyze lockfile = do let path = fromRelFile lockfile @@ -36,13 +36,11 @@ analyze lockfile = do Left err -> throwError (FileParseError path (YL.prettyLockfileError err)) Right a -> pure (mkProjectClosure lockfile a) -mkProjectClosure :: Path Rel File -> YL.Lockfile -> ProjectClosure -mkProjectClosure file lock = ProjectClosure - { closureStrategyGroup = NodejsGroup - , closureStrategyName = "nodejs-yarnlock" - , closureModuleDir = parent file - , closureDependencies = dependencies - , closureLicenses = [] +mkProjectClosure :: Path Rel File -> YL.Lockfile -> ProjectClosureBody +mkProjectClosure file lock = ProjectClosureBody + { bodyModuleDir = parent file + , bodyDependencies = dependencies + , bodyLicenses = [] } where dependencies = ProjectDependencies diff --git a/src/Strategy/NuGet/Nuspec.hs b/src/Strategy/NuGet/Nuspec.hs index fd6f1dba6..3ed1e18f5 100644 --- a/src/Strategy/NuGet/Nuspec.hs +++ b/src/Strategy/NuGet/Nuspec.hs @@ -33,16 +33,14 @@ discover = walk $ \_ _ files -> do walkContinue -analyze :: (Has ReadFS sig m, Has (Error ReadFSErr) sig m) => Path Rel File -> m ProjectClosure +analyze :: (Has ReadFS sig m, Has (Error ReadFSErr) sig m) => Path Rel File -> m ProjectClosureBody analyze file = mkProjectClosure file <$> readContentsXML @Nuspec file -mkProjectClosure :: Path Rel File -> Nuspec -> ProjectClosure -mkProjectClosure file nuspec = ProjectClosure - { closureStrategyGroup = DotnetGroup - , closureStrategyName = "nuget-nuspec" - , closureModuleDir = parent file - , closureDependencies = dependencies - , closureLicenses = [LicenseResult file (nuspecLicenses nuspec)] +mkProjectClosure :: Path Rel File -> Nuspec -> ProjectClosureBody +mkProjectClosure file nuspec = ProjectClosureBody + { bodyModuleDir = parent file + , bodyDependencies = dependencies + , bodyLicenses = [LicenseResult file (nuspecLicenses nuspec)] } where dependencies = ProjectDependencies diff --git a/src/Strategy/NuGet/PackageReference.hs b/src/Strategy/NuGet/PackageReference.hs index 3aeefc4f5..7611257f9 100644 --- a/src/Strategy/NuGet/PackageReference.hs +++ b/src/Strategy/NuGet/PackageReference.hs @@ -33,16 +33,14 @@ discover = walk $ \_ _ files -> do isPackageRefFile :: Path Rel File -> Bool isPackageRefFile file = any (\x -> L.isSuffixOf x (fileName file)) [".csproj", ".xproj", ".vbproj", ".dbproj", ".fsproj"] -analyze :: (Has ReadFS sig m, Has (Error ReadFSErr) sig m) => Path Rel File -> m ProjectClosure +analyze :: (Has ReadFS sig m, Has (Error ReadFSErr) sig m) => Path Rel File -> m ProjectClosureBody analyze file = mkProjectClosure file <$> readContentsXML @PackageReference file -mkProjectClosure :: Path Rel File -> PackageReference -> ProjectClosure -mkProjectClosure file package = ProjectClosure - { closureStrategyGroup = DotnetGroup - , closureStrategyName = "nuget-packagereference" - , closureModuleDir = parent file - , closureDependencies = dependencies - , closureLicenses = [] +mkProjectClosure :: Path Rel File -> PackageReference -> ProjectClosureBody +mkProjectClosure file package = ProjectClosureBody + { bodyModuleDir = parent file + , bodyDependencies = dependencies + , bodyLicenses = [] } where dependencies = ProjectDependencies diff --git a/src/Strategy/NuGet/PackagesConfig.hs b/src/Strategy/NuGet/PackagesConfig.hs index 0327b738c..2ac76f515 100644 --- a/src/Strategy/NuGet/PackagesConfig.hs +++ b/src/Strategy/NuGet/PackagesConfig.hs @@ -38,16 +38,14 @@ newtype PackagesConfig = PackagesConfig { deps :: [NuGetDependency] } deriving (Eq, Ord, Show, Generic) -analyze :: (Has ReadFS sig m, Has (Error ReadFSErr) sig m) => Path Rel File -> m ProjectClosure +analyze :: (Has ReadFS sig m, Has (Error ReadFSErr) sig m) => Path Rel File -> m ProjectClosureBody analyze file = mkProjectClosure file <$> readContentsXML file -mkProjectClosure :: Path Rel File -> PackagesConfig -> ProjectClosure -mkProjectClosure file config = ProjectClosure - { closureStrategyGroup = DotnetGroup - , closureStrategyName = "nuget-packagesconfig" - , closureModuleDir = parent file - , closureDependencies = dependencies - , closureLicenses = [] +mkProjectClosure :: Path Rel File -> PackagesConfig -> ProjectClosureBody +mkProjectClosure file config = ProjectClosureBody + { bodyModuleDir = parent file + , bodyDependencies = dependencies + , bodyLicenses = [] } where dependencies = ProjectDependencies diff --git a/src/Strategy/NuGet/Paket.hs b/src/Strategy/NuGet/Paket.hs index 2ab1b5625..d42cbfc7d 100644 --- a/src/Strategy/NuGet/Paket.hs +++ b/src/Strategy/NuGet/Paket.hs @@ -36,16 +36,14 @@ discover = walk $ \_ _ files -> do walkContinue -analyze :: (Has ReadFS sig m, Has (Error ReadFSErr) sig m) => Path Rel File -> m ProjectClosure +analyze :: (Has ReadFS sig m, Has (Error ReadFSErr) sig m) => Path Rel File -> m ProjectClosureBody analyze file = mkProjectClosure file <$> readContentsParser findSections file -mkProjectClosure :: Path Rel File -> [Section] -> ProjectClosure -mkProjectClosure file sections = ProjectClosure - { closureStrategyGroup = DotnetGroup - , closureStrategyName = "paket-paketlock" - , closureModuleDir = parent file - , closureDependencies = dependencies - , closureLicenses = [] +mkProjectClosure :: Path Rel File -> [Section] -> ProjectClosureBody +mkProjectClosure file sections = ProjectClosureBody + { bodyModuleDir = parent file + , bodyDependencies = dependencies + , bodyLicenses = [] } where dependencies = ProjectDependencies diff --git a/src/Strategy/NuGet/ProjectAssetsJson.hs b/src/Strategy/NuGet/ProjectAssetsJson.hs index 4c0056289..c0d2ed76a 100644 --- a/src/Strategy/NuGet/ProjectAssetsJson.hs +++ b/src/Strategy/NuGet/ProjectAssetsJson.hs @@ -45,16 +45,14 @@ instance FromJSON DependencyInfo where DependencyInfo <$> obj .: "type" <*> obj .:? "dependencies" .!= M.empty -analyze :: (Has ReadFS sig m, Has (Error ReadFSErr) sig m) => Path Rel File -> m ProjectClosure +analyze :: (Has ReadFS sig m, Has (Error ReadFSErr) sig m) => Path Rel File -> m ProjectClosureBody analyze file = mkProjectClosure file <$> readContentsJson @ProjectAssetsJson file -mkProjectClosure :: Path Rel File -> ProjectAssetsJson -> ProjectClosure -mkProjectClosure file projectAssetsJson = ProjectClosure - { closureStrategyGroup = DotnetGroup - , closureStrategyName = "nuget-projectassetsjson" - , closureModuleDir = parent file - , closureDependencies = dependencies - , closureLicenses = [] +mkProjectClosure :: Path Rel File -> ProjectAssetsJson -> ProjectClosureBody +mkProjectClosure file projectAssetsJson = ProjectClosureBody + { bodyModuleDir = parent file + , bodyDependencies = dependencies + , bodyLicenses = [] } where dependencies = ProjectDependencies diff --git a/src/Strategy/NuGet/ProjectJson.hs b/src/Strategy/NuGet/ProjectJson.hs index 7e3d79ac1..ca7b618f8 100644 --- a/src/Strategy/NuGet/ProjectJson.hs +++ b/src/Strategy/NuGet/ProjectJson.hs @@ -52,16 +52,14 @@ instance FromJSON DependencyInfo where parseJSONText = withText "DependencyVersion" $ \text -> pure $ DependencyInfo text Nothing -analyze :: (Has ReadFS sig m, Has (Error ReadFSErr) sig m) => Path Rel File -> m ProjectClosure +analyze :: (Has ReadFS sig m, Has (Error ReadFSErr) sig m) => Path Rel File -> m ProjectClosureBody analyze file = mkProjectClosure file <$> readContentsJson @ProjectJson file -mkProjectClosure :: Path Rel File -> ProjectJson -> ProjectClosure -mkProjectClosure file projectJson = ProjectClosure - { closureStrategyGroup = DotnetGroup - , closureStrategyName = "nuget-projectjson" - , closureModuleDir = parent file - , closureDependencies = dependencies - , closureLicenses = [] +mkProjectClosure :: Path Rel File -> ProjectJson -> ProjectClosureBody +mkProjectClosure file projectJson = ProjectClosureBody + { bodyModuleDir = parent file + , bodyDependencies = dependencies + , bodyLicenses = [] } where dependencies = ProjectDependencies diff --git a/src/Strategy/Python/PipList.hs b/src/Strategy/Python/PipList.hs index c956da508..36e407119 100644 --- a/src/Strategy/Python/PipList.hs +++ b/src/Strategy/Python/PipList.hs @@ -34,16 +34,14 @@ pipListCmd = Command , cmdAllowErr = Never } -analyze :: (Has Exec sig m, Has (Error ExecErr) sig m) => Path Rel Dir -> m ProjectClosure +analyze :: (Has Exec sig m, Has (Error ExecErr) sig m) => Path Rel Dir -> m ProjectClosureBody analyze dir = mkProjectClosure dir <$> execJson @[PipListDep] dir pipListCmd [] -mkProjectClosure :: Path Rel Dir -> [PipListDep] -> ProjectClosure -mkProjectClosure dir deps = ProjectClosure - { closureStrategyGroup = PythonGroup - , closureStrategyName = "python-piplist" - , closureModuleDir = dir - , closureDependencies = dependencies - , closureLicenses = [] +mkProjectClosure :: Path Rel Dir -> [PipListDep] -> ProjectClosureBody +mkProjectClosure dir deps = ProjectClosureBody + { bodyModuleDir = dir + , bodyDependencies = dependencies + , bodyLicenses = [] } where dependencies = ProjectDependencies diff --git a/src/Strategy/Python/Pipenv.hs b/src/Strategy/Python/Pipenv.hs index fd089dfe3..a6dc24442 100644 --- a/src/Strategy/Python/Pipenv.hs +++ b/src/Strategy/Python/Pipenv.hs @@ -46,7 +46,7 @@ analyze :: , Has (Error ReadFSErr) sig m , Effect sig ) - => Path Rel File -> m ProjectClosure + => Path Rel File -> m ProjectClosureBody analyze lockfile = do lock <- readContentsJson lockfile -- TODO: diagnostics? @@ -54,13 +54,11 @@ analyze lockfile = do pure (mkProjectClosure lockfile lock (eitherToMaybe maybeDeps)) -mkProjectClosure :: Path Rel File -> PipfileLock -> Maybe [PipenvGraphDep] -> ProjectClosure -mkProjectClosure file lockfile maybeDeps = ProjectClosure - { closureStrategyGroup = PythonGroup - , closureStrategyName = "python-pipenv" - , closureModuleDir = parent file - , closureDependencies = dependencies - , closureLicenses = [] +mkProjectClosure :: Path Rel File -> PipfileLock -> Maybe [PipenvGraphDep] -> ProjectClosureBody +mkProjectClosure file lockfile maybeDeps = ProjectClosureBody + { bodyModuleDir = parent file + , bodyDependencies = dependencies + , bodyLicenses = [] } where dependencies = ProjectDependencies diff --git a/src/Strategy/Python/ReqTxt.hs b/src/Strategy/Python/ReqTxt.hs index 5041f0e14..abf0f2ace 100644 --- a/src/Strategy/Python/ReqTxt.hs +++ b/src/Strategy/Python/ReqTxt.hs @@ -27,16 +27,14 @@ discover = walk $ \_ _ files -> do walkContinue -analyze :: (Has ReadFS sig m, Has (Error ReadFSErr) sig m) => Path Rel File -> m ProjectClosure +analyze :: (Has ReadFS sig m, Has (Error ReadFSErr) sig m) => Path Rel File -> m ProjectClosureBody analyze file = mkProjectClosure file <$> readContentsParser requirementsTxtParser file -mkProjectClosure :: Path Rel File -> [Req] -> ProjectClosure -mkProjectClosure file reqs = ProjectClosure - { closureStrategyGroup = PythonGroup - , closureStrategyName = "python-requirements" - , closureModuleDir = parent file - , closureDependencies = dependencies - , closureLicenses = [] +mkProjectClosure :: Path Rel File -> [Req] -> ProjectClosureBody +mkProjectClosure file reqs = ProjectClosureBody + { bodyModuleDir = parent file + , bodyDependencies = dependencies + , bodyLicenses = [] } where dependencies = ProjectDependencies diff --git a/src/Strategy/Python/SetupPy.hs b/src/Strategy/Python/SetupPy.hs index 7b94db913..581f8a8a6 100644 --- a/src/Strategy/Python/SetupPy.hs +++ b/src/Strategy/Python/SetupPy.hs @@ -24,16 +24,14 @@ discover = walk $ \_ _ files -> do walkContinue -analyze :: (Has ReadFS sig m, Has (Error ReadFSErr) sig m) => Path Rel File -> m ProjectClosure +analyze :: (Has ReadFS sig m, Has (Error ReadFSErr) sig m) => Path Rel File -> m ProjectClosureBody analyze file = mkProjectClosure file <$> readContentsParser installRequiresParser file -mkProjectClosure :: Path Rel File -> [Req] -> ProjectClosure -mkProjectClosure file reqs = ProjectClosure - { closureStrategyGroup = PythonGroup - , closureStrategyName = "python-setuppy" - , closureModuleDir = parent file - , closureDependencies = dependencies - , closureLicenses = [] +mkProjectClosure :: Path Rel File -> [Req] -> ProjectClosureBody +mkProjectClosure file reqs = ProjectClosureBody + { bodyModuleDir = parent file + , bodyDependencies = dependencies + , bodyLicenses = [] } where dependencies = ProjectDependencies diff --git a/src/Strategy/Ruby/BundleShow.hs b/src/Strategy/Ruby/BundleShow.hs index 0894522d9..ce80bb872 100644 --- a/src/Strategy/Ruby/BundleShow.hs +++ b/src/Strategy/Ruby/BundleShow.hs @@ -36,16 +36,14 @@ bundleShowCmd = Command , cmdAllowErr = Never } -analyze :: (Has Exec sig m, Has (Error ExecErr) sig m) => Path Rel Dir -> m ProjectClosure +analyze :: (Has Exec sig m, Has (Error ExecErr) sig m) => Path Rel Dir -> m ProjectClosureBody analyze dir = mkProjectClosure dir <$> execParser bundleShowParser dir bundleShowCmd [] -mkProjectClosure :: Path Rel Dir -> [BundleShowDep] -> ProjectClosure -mkProjectClosure dir deps = ProjectClosure - { closureStrategyGroup = RubyGroup - , closureStrategyName = "ruby-bundleshow" - , closureModuleDir = dir - , closureDependencies = dependencies - , closureLicenses = [] +mkProjectClosure :: Path Rel Dir -> [BundleShowDep] -> ProjectClosureBody +mkProjectClosure dir deps = ProjectClosureBody + { bodyModuleDir = dir + , bodyDependencies = dependencies + , bodyLicenses = [] } where dependencies = ProjectDependencies diff --git a/src/Strategy/Ruby/GemfileLock.hs b/src/Strategy/Ruby/GemfileLock.hs index 2d5c4d938..7c9754fb3 100644 --- a/src/Strategy/Ruby/GemfileLock.hs +++ b/src/Strategy/Ruby/GemfileLock.hs @@ -61,16 +61,14 @@ newtype DirectDep = DirectDep { directName :: Text } deriving (Eq, Ord, Show, Generic) -analyze :: (Has ReadFS sig m, Has (Error ReadFSErr) sig m) => Path Rel File -> m ProjectClosure +analyze :: (Has ReadFS sig m, Has (Error ReadFSErr) sig m) => Path Rel File -> m ProjectClosureBody analyze file = mkProjectClosure file <$> readContentsParser @[Section] findSections file -mkProjectClosure :: Path Rel File -> [Section] -> ProjectClosure -mkProjectClosure file sections = ProjectClosure - { closureStrategyGroup = RubyGroup - , closureStrategyName = "ruby-gemfilelock" - , closureModuleDir = parent file - , closureDependencies = dependencies - , closureLicenses = [] +mkProjectClosure :: Path Rel File -> [Section] -> ProjectClosureBody +mkProjectClosure file sections = ProjectClosureBody + { bodyModuleDir = parent file + , bodyDependencies = dependencies + , bodyLicenses = [] } where dependencies = ProjectDependencies @@ -137,13 +135,13 @@ buildGraph sections = run . withLabeling toDependency $ type Parser = Parsec Void Text findSections :: Parser [Section] -findSections = many (try gitSectionParser <|> try gemSectionParser <|> try pathSectionParser <|> try dependenciesSectionParser <|> emptySection) <* eof +findSections = manyTill (try gitSectionParser <|> try gemSectionParser <|> try pathSectionParser <|> try dependenciesSectionParser <|> unknownSection) eof -emptySection :: Parser Section -emptySection = do - emptyLine <- restOfLine - _ <- eol - pure $ UnknownSection emptyLine +unknownSection :: Parser Section +unknownSection = do + scn + line <- restOfLine + pure $ UnknownSection line restOfLine :: Parser Text restOfLine = takeWhileP (Just "ignored") (not . isEndLine) @@ -173,70 +171,66 @@ gemSectionParser = mkSectionParser "GEM" $ \propertyMap -> do pure $ GemSection remote specs mkSectionParser :: Text -> (Map Text RawField -> Either Text Section) -> Parser Section -mkSectionParser sectionName toSection = L.nonIndented scn (L.indentBlock scn p) - where - p = do - _ <- chunk sectionName - pure $ L.IndentMany Nothing propertiesToSection (try propertyParser <|> specPropertyParser) - - propertiesToSection :: [(Text, RawField)] -> Parser Section - propertiesToSection properties = - let propertyMap = M.fromList properties - result :: Either Text Section - result = toSection propertyMap - - in case result of - Right x -> pure x - Left y -> fail $ T.unpack $ "could not parse " <> sectionName <> " section: " <> y +mkSectionParser sectionName toSection = L.nonIndented scn $ L.indentBlock scn $ do + _ <- chunk sectionName + pure $ L.IndentMany Nothing propertiesToSection (try propertyParser <|> specPropertyParser) + + where + propertiesToSection :: [(Text, RawField)] -> Parser Section + propertiesToSection properties = + let propertyMap = M.fromList properties + result :: Either Text Section + result = toSection propertyMap + + in case result of + Right x -> pure x + Left y -> fail $ T.unpack $ "could not parse " <> sectionName <> " section: " <> y eitherToMaybe :: Either a b -> Maybe b eitherToMaybe (Right a) = Just a eitherToMaybe (Left _) = Nothing lookupRawText :: Text -> Map Text RawField -> Either Text Text -lookupRawText key m = let value = M.lookup key m - in - case value of - Just (RawText val) -> Right val - _ -> Left $ "a value for " <> key <> " was unable to be found in the map" +lookupRawText key m = case M.lookup key m of + Just (RawText val) -> Right val + _ -> Left $ "a value for " <> key <> " was unable to be found in the map" lookupRawSpecs :: Text -> Map Text RawField -> Either Text [Spec] -lookupRawSpecs key m = let value = M.lookup key m - in - case value of - Just (RawSpecs val) -> Right val - _ -> Left $ "a value for " <> key <> " was unable to be found in the map" +lookupRawSpecs key m = case M.lookup key m of + Just (RawSpecs val) -> Right val + _ -> Left $ "a value for " <> key <> " was unable to be found in the map" -data RawField = RawText Text - | RawSpecs [Spec] - deriving (Eq, Ord, Show, Generic) +data RawField + = RawText Text + | RawSpecs [Spec] + deriving (Eq, Ord, Show, Generic) propertyParser :: Parser (Text, RawField) propertyParser = do - remote <- findFieldName - _ <- chunk ":" - value <- textValue - pure (remote, value) + remote <- findFieldName + _ <- chunk ":" + value <- textValue + pure (remote, value) - where - findFieldName :: Parser Text - findFieldName = takeWhileP (Just "field name") (/= ':') + where + findFieldName :: Parser Text + findFieldName = takeWhileP (Just "field name") (/= ':') - textValue :: Parser RawField - textValue = do - _ <- chunk " " - RawText <$> restOfLine + textValue :: Parser RawField + textValue = do + _ <- chunk " " + RawText <$> restOfLine specPropertyParser :: Parser (Text, RawField) -specPropertyParser = L.indentBlock scn p - where - p = do - remote <- findFieldName - _ <- chunk ":" - pure $ L.IndentMany Nothing (\a -> pure (remote, RawSpecs a)) specParser - - findFieldName :: Parser Text - findFieldName = takeWhileP (Just "field name") (/= ':') +specPropertyParser = L.indentBlock scn $ do + remote <- findFieldName + _ <- chunk ":" + pure $ L.IndentMany Nothing (\a -> pure (remote, RawSpecs a)) specParser + + where + + findFieldName :: Parser Text + findFieldName = takeWhileP (Just "field name") (/= ':') isEndLine :: Char -> Bool isEndLine '\n' = True @@ -278,11 +272,9 @@ findVersion = do dependenciesSectionParser :: Parser Section -dependenciesSectionParser = L.nonIndented scn (L.indentBlock scn p) - where - p = do - _ <- chunk "DEPENDENCIES" - pure $ L.IndentMany Nothing (\deps -> pure $ DependencySection deps) findDependency +dependenciesSectionParser = L.nonIndented scn $ L.indentBlock scn $ do + _ <- chunk "DEPENDENCIES" + pure $ L.IndentMany Nothing (\deps -> pure $ DependencySection deps) findDependency findDependency :: Parser DirectDep findDependency = do diff --git a/src/Types.hs b/src/Types.hs index 2e33d3cfb..8acc2e6ae 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -2,6 +2,8 @@ module Types ( StrategyGroup(..) , ProjectClosure(..) + , ProjectClosureBody(..) + , ProjectFailure(..) , Optimal(..) , Complete(..) @@ -23,7 +25,7 @@ import Control.Algebra import Control.Carrier.Error.Either import Control.Carrier.TaskPool import Control.Effect.Exception -import Control.Effect.Output +import Control.Carrier.Output.IO import DepTypes import Effect.Exec import Effect.Logger @@ -36,48 +38,44 @@ runSimpleStrategy :: ( Has (Lift IO) sig m , Has TaskPool sig m , Has (Output ProjectClosure) sig m + , Has (Output ProjectFailure) sig m + , MonadIO m + , Effect sig ) - => Text -> StrategyGroup -> TaskC m ProjectClosure -> m () -runSimpleStrategy _ _ act = forkTask $ do - let runIt = runError @ReadFSErr - . runError @ExecErr - . runReadFSIO - . runExecIO - - mask $ \restore -> do - (res :: Either SomeException a) <- try (restore (runIt act)) - case res of - Left _ -> pure () -- TODO - Right (Left _) -> pure () -- TODO - Right (Right (Left _)) -> pure () -- TODO - Right (Right (Right a)) -> output a + => Text -> StrategyGroup -> TaskC m ProjectClosureBody -> m () +runSimpleStrategy name strategyGroup act = runStrategy name strategyGroup (lift act >>= output) runStrategy :: ( Has (Lift IO) sig m , Has TaskPool sig m + , Has (Output ProjectClosure) sig m + , Has (Output ProjectFailure) sig m + , MonadIO m ) - => Text -> StrategyGroup -> TaskC m () -> m () -runStrategy _ _ act = forkTask $ do + => Text -> StrategyGroup -> OutputC ProjectClosureBody (TaskC m) () -> m () +runStrategy name strategyGroup act = forkTask $ do let runIt = runError @ReadFSErr . runError @ExecErr . runReadFSIO . runExecIO + . runOutput @ProjectClosureBody mask $ \restore -> do (res :: Either SomeException a) <- try (restore (runIt act)) case res of - Left _ -> pure () -- TODO - Right (Left _) -> pure () -- TODO - Right (Right (Left _)) -> pure () -- TODO - Right (Right (Right ())) -> pure () + Left exc -> output (ProjectFailure strategyGroup name exc) + Right (Left exc) -> output (ProjectFailure strategyGroup name (SomeException exc)) + Right (Right (Left exc)) -> output (ProjectFailure strategyGroup name (SomeException exc)) + Right (Right (Right (bodies,()))) -> traverse_ (output . toProjectClosure strategyGroup name) bodies -type TaskC m a = ExecIOC (ReadFSIOC (ErrorC ExecErr (ErrorC ReadFSErr m))) a +type TaskC m = (ExecIOC (ReadFSIOC (ErrorC ExecErr (ErrorC ReadFSErr m)))) type HasDiscover sig m = ( Has (Lift IO) sig m , Has Logger sig m , Has TaskPool sig m , Has (Output ProjectClosure) sig m + , Has (Output ProjectFailure) sig m , MonadIO m , Effect sig ) @@ -98,6 +96,27 @@ instance ToJSON Complete where toJSON Complete = toJSON True toJSON NotComplete = toJSON False +data ProjectFailure = ProjectFailure + { projectFailureGroup :: StrategyGroup + , projectFailureName :: Text + , projectFailureCause :: SomeException + } deriving (Show, Generic) + +toProjectClosure :: StrategyGroup -> Text -> ProjectClosureBody -> ProjectClosure +toProjectClosure strategyGroup name body = ProjectClosure + { closureStrategyGroup = strategyGroup + , closureStrategyName = name + , closureModuleDir = bodyModuleDir body + , closureDependencies = bodyDependencies body + , closureLicenses = bodyLicenses body + } + +data ProjectClosureBody = ProjectClosureBody + { bodyModuleDir :: Path Rel Dir + , bodyDependencies :: ProjectDependencies + , bodyLicenses :: [LicenseResult] + } deriving (Eq, Ord, Show, Generic) + data ProjectClosure = ProjectClosure { closureStrategyGroup :: StrategyGroup , closureStrategyName :: Text -- ^ e.g., "python-pipenv". This is temporary: ProjectClosures will eventually combine several strategies into one diff --git a/test/Cocoapods/PodfileLockTest.hs b/test/Cocoapods/PodfileLockTest.hs index a6bdc29c1..25dd4cfaf 100644 --- a/test/Cocoapods/PodfileLockTest.hs +++ b/test/Cocoapods/PodfileLockTest.hs @@ -69,7 +69,7 @@ spec_analyze = do T.describe "podfile lock parser" $ T.it "parses error messages into an empty list" $ case runParser findSections "" podLockFile of - Left _ -> T.expectationFailure "failed to parse" + Left err -> T.expectationFailure ("failed to parse: " <> errorBundlePretty err) Right result -> do - result `T.shouldContain` [podSection] - result `T.shouldContain` [dependencySection] + result `T.shouldContain` [podSection] + result `T.shouldContain` [dependencySection] diff --git a/test/Go/GoListTest.hs b/test/Go/GoListTest.hs index 8bba69e38..474ce8856 100644 --- a/test/Go/GoListTest.hs +++ b/test/Go/GoListTest.hs @@ -65,7 +65,7 @@ spec_analyze = do & run case result of Left err -> expectationFailure ("analyze failed: " <> show err) - Right closure -> dependenciesGraph (closureDependencies closure) `shouldBe` expected + Right body -> dependenciesGraph (bodyDependencies body) `shouldBe` expected it "can handle complex inputs" $ do let result = @@ -76,4 +76,4 @@ spec_analyze = do case result of Left err -> fail $ "failed to build graph" <> show err - Right closure -> length (graphingDirect (dependenciesGraph (closureDependencies closure))) `shouldBe` 12 + Right body -> length (graphingDirect (dependenciesGraph (bodyDependencies body))) `shouldBe` 12