Hack Week - ELF/PE Parsers

.github/workflows/report.yml

@@ -0,0 +1,31 @@
+on:
+  release:
+    types: [published]
+
+jobs:
+  add-attributions-to-release:
+    name: add-attributions-to-release ${{ github.event.release.tag_name }}
+    runs-on: ubuntu-latest
+
+    # release changes require contents write
+    permissions:
+      contents: write 
+
+    steps:
+      - uses: actions/checkout@v4
+      - name: Install fossa-cli
+        run: |
+          ./install-latest.sh -d
+
+      # since this is only invoked after the release is published,
+      # we can safely presume that fossa has ran dependency scan on the commit
+      # from 'dependency-scan' job!
+      #
+      # docs: https://cli.github.com/manual/gh_release_upload
+      - name: Persist attributions to release
+        run: |
+          fossa report --format cyclonedx-json attribution > fossa-cli-attribution.bom.json
+          gh release upload ${{ github.event.release.tag_name }} fossa-cli-attribution.bom.json
+        env:
+          FOSSA_API_KEY: ${{ secrets.FOSSA_API_KEY }}
+          GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}

spectrometer.cabal

@@ -24,6 +24,7 @@ extra-source-files:
   vendor-bins/index.gob.xz
   vendor-bins/lernie
   vendor-bins/themis-cli
+  vendor-bins/execsnooper
 
 common lang
   build-depends:      base >=4.15 && <5
@@ -392,6 +393,7 @@ library
     Strategy.ApkDatabase
     Strategy.BerkeleyDB
     Strategy.BerkeleyDB.Internal
+    Strategy.Binary
     Strategy.Bundler
     Strategy.Cargo
     Strategy.Carthage

src/App/Fossa/Analyze.hs

@@ -16,7 +16,7 @@ import App.Docs (userGuideUrl)
 import App.Fossa.Analyze.Debug (collectDebugBundle, diagToDebug)
 import App.Fossa.Analyze.Discover (
   DiscoverFunc (..),
-  discoverFuncs,
+  getDiscoveryFuncs,
  )
 import App.Fossa.Analyze.Filter (
   CountedResult (..),
@@ -259,6 +259,7 @@ runAnalyzers allowedTactics filters withoutDefaultFilters basedir pathPrefix = d
     else traverse_ single discoverFuncs
   where
     single (DiscoverFunc f) = withDiscoveredProjects f basedir (runDependencyAnalysis basedir filters withoutDefaultFilters pathPrefix allowedTactics)
+    discoverFuncs = getDiscoveryFuncs
 
 analyze ::
   ( Has Debug sig m

src/App/Fossa/Analyze/Discover.hs

@@ -1,5 +1,6 @@
 module App.Fossa.Analyze.Discover (
   discoverFuncs,
+  getDiscoveryFuncs,
   DiscoverFunc (..),
 ) where
 
@@ -45,6 +46,10 @@ import Strategy.Rebar3 qualified as Rebar3
 import Strategy.Scala qualified as Scala
 import Strategy.SwiftPM qualified as SwiftPM
 import Types (DiscoveredProject)
+import Strategy.Binary qualified as Binary
+
+getDiscoveryFuncs :: DiscoverTaskEffs sig m => [DiscoverFunc m]
+getDiscoveryFuncs = discoverFuncs
 
 discoverFuncs :: DiscoverTaskEffs sig m => [DiscoverFunc m]
 discoverFuncs =
@@ -84,6 +89,7 @@ discoverFuncs =
   , DiscoverFunc Setuptools.discover
   , DiscoverFunc Stack.discover
   , DiscoverFunc SwiftPM.discover
+  , DiscoverFunc Binary.discover
   ]
 
 -- DiscoverFunc is a workaround for the lack of impredicative types.

src/App/Fossa/Container/Sources/Discovery.hs

@@ -52,6 +52,8 @@ import Strategy.R qualified as R
 import Strategy.RPM qualified as RPM
 import Strategy.Sqlite qualified as Sqlite
 import Strategy.SwiftPM qualified as SwiftPM
+import Strategy.Binary qualified as Binary
+
 import Types (
   BuildTarget (unBuildTarget),
   DiscoveredProject (projectBuildTargets, projectPath, projectType),
@@ -101,6 +103,7 @@ managedDepsDiscoveryF =
   , DiscoverFunc RepoManifest.discover
   , DiscoverFunc Setuptools.discover
   , DiscoverFunc SwiftPM.discover
+  , DiscoverFunc Binary.discover
   --
   -- Following can be performed only with dynamic analysis.
   -- So we don not do any discovery for them (to avoid error noise)

src/App/Fossa/EmbeddedBinary.hs

@@ -12,6 +12,7 @@ module App.Fossa.EmbeddedBinary (
   withBerkeleyBinary,
   withLernieBinary,
   withMillhoneBinary,
+  withExecSnooperBinary,
   allBins,
   dumpEmbeddedBinary,
   themisVersion,
@@ -59,6 +60,7 @@ data PackagedBinary
   | BerkeleyDB
   | Lernie
   | Millhone
+  | ExecSnooper
   deriving (Show, Eq, Enum, Bounded)
 
 allBins :: [PackagedBinary]
@@ -128,6 +130,13 @@ withMillhoneBinary ::
   m c
 withMillhoneBinary = withEmbeddedBinary Millhone
 
+withExecSnooperBinary ::
+  ( Has (Lift IO) sig m
+  ) =>
+  (BinaryPaths -> m c) ->
+  m c
+withExecSnooperBinary = withEmbeddedBinary ExecSnooper
+
 withEmbeddedBinary ::
   ( Has (Lift IO) sig m
   ) =>
@@ -161,6 +170,7 @@ writeBinary dest bin = sendIO . writeExecutable dest $ case bin of
   BerkeleyDB -> embeddedBinaryBerkeleyDB
   Lernie -> embeddedBinaryLernie
   Millhone -> embeddedBinaryMillhone
+  ExecSnooper -> embeddedBinaryExecSnooper
 
 writeExecutable :: Path Abs File -> ByteString -> IO ()
 writeExecutable path content = do
@@ -175,6 +185,7 @@ extractedPath bin = case bin of
   BerkeleyDB -> $(mkRelFile "berkeleydb-plugin")
   Lernie -> $(mkRelFile "lernie")
   Millhone -> $(mkRelFile "millhone")
+  ExecSnooper -> $(mkRelFile "execsnooper")
 
 -- | Extract to @$TMP/fossa-vendor/<uuid>
 -- We used to extract everything to @$TMP/fossa-vendor@, but there's a subtle issue with that.
@@ -215,6 +226,9 @@ themisVersion = $$(themisVersionQ)
 embeddedBinaryLernie :: ByteString
 embeddedBinaryLernie = $(embedFileIfExists "vendor-bins/lernie")
 
+embeddedBinaryExecSnooper :: ByteString
+embeddedBinaryExecSnooper = $(embedFileIfExists "vendor-bins/execsnooper")
+
 -- To build this, run `make build` or `cargo build --release`.
 #ifdef mingw32_HOST_OS
 embeddedBinaryMillhone :: ByteString

src/App/Fossa/VSI/Fingerprint.hs

@@ -10,6 +10,7 @@ module App.Fossa.VSI.Fingerprint (
   Raw,
   CommentStripped,
   Combined (..),
+  fingerprintRawBs,
 ) where
 
 import Conduit (ConduitT, await, filterC, linesUnboundedAsciiC, mapC, runConduitRes, sourceFile, yield, (.|))
@@ -67,6 +68,13 @@ instance ToJSON Combined where
 encodeFingerprint :: Digest SHA256 -> Fingerprint t
 encodeFingerprint = Fingerprint . toText . show
 
+-- | Hashes the bytestring.
+hashBs :: (Has (Lift IO) sig m, Has Diagnostics sig m, HashAlgorithm hash) => ByteString -> m (Digest hash)
+hashBs fp =
+  context "as binary" $
+    (fatalOnIOException "hash bs") . sendIO . runConduitRes $
+      yield fp .| sinkHash
+
 -- | Hashes the whole contents of the given file in constant memory.
 hashBinaryFile :: (Has (Lift IO) sig m, Has Diagnostics sig m, HashAlgorithm hash) => FilePath -> m (Digest hash)
 hashBinaryFile fp =
@@ -91,6 +99,13 @@ hashTextFile file =
         .| mapC (<> "\n") -- Always append a newline here
         .| sinkHash -- Hash the result
 
+fingerprintRawBs :: (Has ReadFS sig m, Has (Lift IO) sig m, Has Diagnostics sig m) => ByteString -> m (Fingerprint Raw)
+fingerprintRawBs bs = context "raw" doFingerprint
+  where
+    doFingerprint = do
+      fp <- hashBs bs
+      pure $ encodeFingerprint fp
+
 fingerprintRaw :: (Has ReadFS sig m, Has (Lift IO) sig m, Has Diagnostics sig m) => Path Abs File -> m (Fingerprint Raw)
 fingerprintRaw file = context "raw" $ contentIsBinary file >>= doFingerprint
   where

src/DepTypes.hs

@@ -129,6 +129,8 @@ data DepType
     UnresolvedPathType
   | -- | Path Type
     PathType -- effectively any dependency which have been license scanned from filesystem.
+  | -- | Unknown Binary Type
+    UnknownBinaryType 
   deriving (Eq, Ord, Show, Generic, Enum, Bounded)
 
 data VerConstraint

src/Effect/Exec.hs

@@ -31,6 +31,9 @@
   CandidateAnalysisCommands (..),
   mkAnalysisCommand,
   mkSingleCandidateAnalysisCommand,
+  ExecStdin(..),
+  execCurrentDirStdinBsThrow,
+  execStdinBsThrow,
 ) where
 
 import App.Support (reportDefectMsg)
@@ -53,7 +56,7 @@
   warnOnErr,
  )
 import Control.Effect.Lift (Lift, sendIO)
-import Control.Effect.Record (RecordableValue (..))
+import Control.Effect.Record (RecordableValue (..), Redacted)
 import Control.Effect.Record.TH (deriveRecordable)
 import Control.Effect.Replay (ReplayableValue (..))
 import Control.Effect.Replay.TH (deriveReplayable)
@@ -93,10 +96,12 @@
   proc,
   readProcess,
   setStdin,
-  setWorkingDir,
+  setWorkingDir, byteStringInput,
  )
 import Text.Megaparsec (Parsec, runParser)
 import Text.Megaparsec.Error (errorBundlePretty)
+import Control.Applicative (some, (<|>))
+import Data.ByteString.Lazy (ByteString)
 
 data Command = Command
   { cmdName :: Text
@@ -163,14 +168,33 @@
 instance ReplayableValue AllowErr
 
 type Stdout = BL.ByteString
-
 type Stderr = BL.ByteString
 
+data ExecStdin = ExecStdinText Text 
+  | ExecStdinByteString ByteString
+  deriving (Show, Generic, Eq, Ord)
+
+instance ToJSON ExecStdin where
+  toJSON (ExecStdinText txt) =
+    object
+      [ "ExecStdinText" .= txt
+      ]
+  toJSON (ExecStdinByteString _) =
+    object
+      [ "ExecStdinByteString" .= ("redacted" :: Text)
+      ]
+
+instance FromJSON ExecStdin where
+  parseJSON = withObject "ExecStdin" $ \obj -> ExecStdinText <$> obj .: "ExecStdinText"
+
+instance RecordableValue ExecStdin
+instance ReplayableValue ExecStdin
+
 data ExecF a where
   -- | Exec runs a command and returns either:
   -- - stdout when the command succeeds
   -- - a description of the command failure
-  Exec :: SomeBase Dir -> Command -> Maybe Text -> ExecF (Either CmdFailure Stdout)
+  Exec :: SomeBase Dir -> Command -> Maybe ExecStdin -> ExecF (Either CmdFailure Stdout)
 
 type Exec = Simple ExecF
 
@@ -305,7 +329,10 @@
 
 -- | Execute a command with stdin and return its @(exitcode, stdout, stderr)@
 exec' :: Has Exec sig m => Path Abs Dir -> Command -> Text -> m (Either CmdFailure Stdout)
-exec' dir cmd stdin = sendSimple (Exec (Abs dir) cmd (Just stdin))
+exec' dir cmd stdin = sendSimple (Exec (Abs dir) cmd (Just $ ExecStdinText stdin))
+
+execBs' :: Has Exec sig m => Path Abs Dir -> Command -> ByteString -> m (Either CmdFailure Stdout)
+execBs' dir cmd stdin = sendSimple (Exec (Abs dir) cmd (Just $ ExecStdinByteString stdin))
 
 type Parser = Parsec Void Text
 
@@ -380,6 +407,23 @@
     Left failure -> fatal (CommandFailed failure)
     Right stdout -> pure stdout
 
+-- | A variant of 'execThrow' that runs the command in the directory and accepts stdin in bytestring
+execStdinBsThrow :: (Has Exec sig m, Has ReadFS sig m, Has Diagnostics sig m) => Command -> Path Abs Dir -> ByteString -> m BL.ByteString
+execStdinBsThrow cmd dir stdin = do
+  result <- execBs' dir cmd stdin
+  case result of
+    Left failure -> fatal (CommandFailed failure)
+    Right stdout -> pure stdout
+
+-- | A variant of 'execThrow' that runs the command in the current directory and accepts stdin in bytestring
+execCurrentDirStdinBsThrow :: (Has Exec sig m, Has ReadFS sig m, Has Diagnostics sig m) => Command -> ByteString -> m BL.ByteString
+execCurrentDirStdinBsThrow cmd stdin = do
+  dir <- getCurrentDir
+  result <- execBs' dir cmd stdin
+  case result of
+    Left failure -> fatal (CommandFailed failure)
+    Right stdout -> pure stdout
+
 -- | Shorthand for the effects needed to select a candidate analysis command.
 type CandidateCommandEffs sig m = (Has Diagnostics sig m, Has Exec sig m, Has (Reader OverrideDynamicAnalysisBinary) sig m)
 
@@ -482,8 +526,10 @@
 
     let process = setWorkingDir (fromAbsDir absolute) (proc cmdName' cmdArgs')
     processResult <- try . readProcess $ case stdin of
-      Just stdin' -> setStdin (fromString . toString $ stdin') process
       Nothing -> process
+      Just (ExecStdinText stdin') -> setStdin (fromString . toString $ stdin') process
+      Just (ExecStdinByteString stdinbs') -> setStdin (byteStringInput stdinbs') process
+
 
     -- apply business logic for considering whether exitcode + stderr constitutes a "failure"
     let mangleResult :: (ExitCode, Stdout, Stderr) -> Either CmdFailure Stdout

src/Srclib/Converter.hs

@@ -173,6 +173,7 @@ depTypeToFetcher = \case
   SwiftType -> "swift"
   UnresolvedPathType -> "upath"
   PathType -> "path"
+  UnknownBinaryType -> "unresolved-binary"
 
 -- | GooglesourceType and SubprojectType are not supported with this function, since they're ambiguous.
 fetcherToDepType :: Text -> Maybe DepType
@@ -203,4 +204,5 @@ fetcherToDepType fetcher | depTypeToFetcher URLType == fetcher = Just URLType
 fetcherToDepType fetcher | depTypeToFetcher UserType == fetcher = Just UserType
 fetcherToDepType fetcher | depTypeToFetcher PubType == fetcher = Just PubType
 fetcherToDepType fetcher | depTypeToFetcher PathType == fetcher = Just PathType
+fetcherToDepType fetcher | depTypeToFetcher UnknownBinaryType == fetcher = Just UnknownBinaryType
 fetcherToDepType _ = Nothing