Include project failures in the analysis blob (#40)

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

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

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
 

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
-

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 ]"

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

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)

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)
 

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

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

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

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

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