|
| 1 | +{-# LANGUAGE RecordWildCards #-} |
| 2 | + |
| 3 | +module App.Fossa.Ficus.Analyze ( |
| 4 | + analyzeWithFicus |
| 5 | +) where |
| 6 | + |
| 7 | +import App.Fossa.EmbeddedBinary (BinaryPaths, toPath, withFicusBinary) |
| 8 | +import App.Fossa.Ficus.Types (FicusSnippetScanResults (..), FicusMessages (..), FicusMessage (..), FicusConfig (..), FicusDebug (..), FicusMessageData (..), FicusError (..), FicusFinding (..), FicusAnalysisFlag (..), FicusAllFlag (..), FicusPerStrategyFlag (..)) |
| 9 | +import App.Types (FileUpload (..), ProjectRevision (..)) |
| 10 | +import Control.Carrier.Debug (Debug) |
| 11 | +import Control.Carrier.Diagnostics (Diagnostics, fatal, warn) |
| 12 | +import Control.Carrier.FossaApiClient (runFossaApiClient) |
| 13 | +import Control.Carrier.Telemetry.Types |
| 14 | +import Control.Effect.FossaApiClient (FossaApiClient, getOrganization) |
| 15 | +import Control.Effect.Lift (Has, Lift) |
| 16 | +import Control.Effect.Telemetry (Telemetry, trackUsage) |
| 17 | +import Control.Monad (join, unless) |
| 18 | +import Data.Aeson (decode, Object, (.:)) |
| 19 | +import Data.Aeson.Types (parseMaybe) |
| 20 | +import Data.ByteString.Lazy qualified as BL |
| 21 | +import Data.Foldable (fold, traverse_) |
| 22 | +import Data.HashMap.Internal.Strict (HashMap) |
| 23 | +import Data.HashMap.Strict qualified as H |
| 24 | +import Data.HashMap.Strict qualified as HashMap |
| 25 | +import Data.Hashable (Hashable) |
| 26 | +import Data.List (nub) |
| 27 | +import Data.List.NonEmpty qualified as NE |
| 28 | +import Data.Maybe (mapMaybe) |
| 29 | +import Data.String.Conversion (ToText (toText), decodeUtf8) |
| 30 | +import Data.Text (Text) |
| 31 | +import Data.Text qualified as Text |
| 32 | +import Data.Text.Encoding qualified as Text.Encoding |
| 33 | +import Effect.Exec (AllowErr (Never), Command (..), Exec, execCurrentDirStdinThrow, execThrow') |
| 34 | +import Effect.ReadFS (ReadFS) |
| 35 | +import Fossa.API.Types (ApiKey (..), ApiOpts (..), Organization (..), orgFileUpload) |
| 36 | +import Path (Abs, Dir, File, Path, toFilePath) |
| 37 | +import Prettyprinter (pretty) |
| 38 | +import Srclib.Types |
| 39 | + ( LicenseScanType (..) |
| 40 | + , LicenseSourceUnit (..) |
| 41 | + , LicenseUnit (..) |
| 42 | + , LicenseUnitData (..) |
| 43 | + , LicenseUnitInfo (..) |
| 44 | + , LicenseUnitMatchData (..) |
| 45 | + , Locator (..) |
| 46 | + , renderLocator |
| 47 | + ) |
| 48 | +import Effect.Logger (Logger, logDebug, logInfo, logError) |
| 49 | +import Text.URI (render) |
| 50 | +import Text.URI.Builder (PathComponent (..), TrailingSlash (..), setPath) |
| 51 | +import Types (GlobFilter (..), LicenseScanPathFilters (..), LicenseScanPathFilters) |
| 52 | +import Prelude hiding (unwords) |
| 53 | +import Data.Flag (Flag, fromFlag) |
| 54 | +import App.Fossa.Config.Analyze (SnippetScan) |
| 55 | +import qualified App.Fossa.Config.Analyze as Config |
| 56 | +-- | scan rootDir with Ficus, using the given GrepOptions. This is the main entry point to this module |
| 57 | +analyzeWithFicus :: |
| 58 | + ( Has Diagnostics sig m |
| 59 | + , Has (Lift IO) sig m |
| 60 | + , Has Exec sig m |
| 61 | + , Has ReadFS sig m |
| 62 | + , Has Logger sig m |
| 63 | + ) => |
| 64 | + Flag SnippetScan -> |
| 65 | + Path Abs Dir -> |
| 66 | + Maybe ApiOpts -> |
| 67 | + ProjectRevision -> |
| 68 | + Maybe LicenseScanPathFilters -> |
| 69 | + m (Maybe FicusSnippetScanResults) |
| 70 | +analyzeWithFicus snippetScan rootDir apiOpts revision filters = do |
| 71 | + if fromFlag Config.SnippetScan snippetScan |
| 72 | + then do |
| 73 | + logInfo $ "Running Ficus analysis on " <> pretty (toFilePath rootDir) |
| 74 | + messages <- runFicus ficusConfig |
| 75 | + let ficusResults = ficusMessagesToFicusSnippetScanResults messages |
| 76 | + case ficusResults of |
| 77 | + Just results -> do |
| 78 | + logInfo $ "Ficus analysis completed successfully with analysis ID: " <> pretty (ficusSnippetScanResultsAnalysisId results) |
| 79 | + Nothing -> logError "Ficus analysis completed but no fingerprint findings were found" |
| 80 | + pure ficusResults |
| 81 | + else do |
| 82 | + logInfo $ "Skipping Ficus analysis on " <> pretty (toFilePath rootDir) |
| 83 | + pure Nothing |
| 84 | + where |
| 85 | + ficusConfig = |
| 86 | + FicusConfig |
| 87 | + { ficusConfigRootDir = rootDir |
| 88 | + , ficusConfigExclude = maybe [] licenseScanPathFiltersExclude filters |
| 89 | + , ficusConfigEndpoint = apiOptsUri =<< apiOpts |
| 90 | + , ficusConfigSecret = apiOptsApiKey <$> apiOpts |
| 91 | + , ficusConfigRevision = revision |
| 92 | + , ficusConfigFlags = [All $ FicusAllFlag SkipHiddenFiles, All $ FicusAllFlag Gitignore] |
| 93 | + } |
| 94 | + |
| 95 | +runFicus :: |
| 96 | + ( Has Diagnostics sig m |
| 97 | + , Has (Lift IO) sig m |
| 98 | + , Has ReadFS sig m |
| 99 | + , Has Exec sig m |
| 100 | + , Has Logger sig m |
| 101 | + ) => |
| 102 | + FicusConfig -> |
| 103 | + m FicusMessages |
| 104 | +runFicus ficusConfig = do |
| 105 | + withFicusBinary $ \bin -> do |
| 106 | + cmd <- ficusCommand ficusConfig bin |
| 107 | + logDebug $ "Executing Ficus command: " <> pretty (show cmd) |
| 108 | + result <- execThrow' cmd |
| 109 | + let messages = parseFicusJson result |
| 110 | + |
| 111 | + -- Log findings at debug level for visibility |
| 112 | + traverse_ (logDebug . pretty . displayFicusFinding) $ ficusMessageFindings messages |
| 113 | + traverse_ (logError . pretty . displayFicusError) $ ficusMessageErrors messages |
| 114 | + traverse_ (logDebug . pretty . displayFicusDebug) $ ficusMessageDebugs messages |
| 115 | + |
| 116 | + pure messages |
| 117 | + where |
| 118 | + displayFicusDebug :: FicusDebug -> Text |
| 119 | + displayFicusDebug (FicusDebug FicusMessageData{..}) = "DEBUG " <> ficusMessageDataStrategy <> ": " <> ficusMessageDataPayload |
| 120 | + displayFicusError :: FicusError -> Text |
| 121 | + displayFicusError (FicusError FicusMessageData{..}) = "ERROR " <> ficusMessageDataStrategy <> ": " <> ficusMessageDataPayload |
| 122 | + displayFicusFinding :: FicusFinding -> Text |
| 123 | + displayFicusFinding (FicusFinding FicusMessageData{..}) = "FINDING " <> ficusMessageDataStrategy <> ": " <> ficusMessageDataPayload |
| 124 | + |
| 125 | + |
| 126 | +ficusMessagesToFicusSnippetScanResults :: FicusMessages -> Maybe FicusSnippetScanResults |
| 127 | +ficusMessagesToFicusSnippetScanResults messages = |
| 128 | + let isFingerprintStrategy :: FicusFinding -> Bool |
| 129 | + isFingerprintStrategy (FicusFinding (FicusMessageData strategy _)) = |
| 130 | + Text.toLower strategy == "fingerprint" |
| 131 | + |
| 132 | + extractAnalysisId :: FicusFinding -> Maybe Int |
| 133 | + extractAnalysisId (FicusFinding (FicusMessageData _ payload)) = |
| 134 | + case decode (BL.fromStrict $ Text.Encoding.encodeUtf8 payload) :: Maybe Object of |
| 135 | + Just obj -> parseMaybe (.: "analysis_id") obj |
| 136 | + Nothing -> Nothing |
| 137 | + |
| 138 | + matchingFinding = filter isFingerprintStrategy (ficusMessageFindings messages) |
| 139 | + analysisId = mapMaybe extractAnalysisId matchingFinding |
| 140 | + in case analysisId of |
| 141 | + (aid : _) -> Just $ FicusSnippetScanResults{ficusSnippetScanResultsAnalysisId = aid} |
| 142 | + [] -> Nothing |
| 143 | + |
| 144 | +-- Run Ficus, passing config-based args as configuration. |
| 145 | +-- Caveat! This hard-codes some flags currently which may later need to be set on a strategy-by-strategy basis. |
| 146 | +ficusCommand :: Has Diagnostics sig m => FicusConfig -> BinaryPaths -> m Command |
| 147 | +ficusCommand ficusConfig bin = do |
| 148 | + endpoint <- case ficusConfigEndpoint ficusConfig of |
| 149 | + Just baseUri -> do |
| 150 | + proxyUri <- setPath [PathComponent "api", PathComponent "proxy"] (TrailingSlash False) baseUri |
| 151 | + pure $ render proxyUri |
| 152 | + Nothing -> pure "" |
| 153 | + pure $ Command |
| 154 | + { cmdName = toText $ toPath bin |
| 155 | + , cmdArgs = configArgs endpoint |
| 156 | + , cmdAllowErr = Never |
| 157 | + } |
| 158 | + where |
| 159 | + configArgs endpoint = ["analyze", "--secret", secret, "--endpoint", endpoint, "--locator", locator, "--set", "all:skip-hidden-files", "--set", "all:gitignore"] ++ configExcludes ++ [targetDir] |
| 160 | + targetDir = toText $ toFilePath $ ficusConfigRootDir ficusConfig |
| 161 | + secret = maybe "" (toText . unApiKey) $ ficusConfigSecret ficusConfig |
| 162 | + locator = renderLocator $ Locator "custom" (projectName $ ficusConfigRevision ficusConfig) (Just $ projectRevision $ ficusConfigRevision ficusConfig) |
| 163 | + configExcludes = unGlobFilter <$> ficusConfigExclude ficusConfig |
| 164 | + |
| 165 | +-- Parse Ficus's NDJson output by splitting on newlines (character 10) and |
| 166 | +-- then decoding each line |
| 167 | +parseFicusJson :: BL.ByteString -> FicusMessages |
| 168 | +parseFicusJson out = |
| 169 | + fold messages |
| 170 | + where |
| 171 | + messageLines = BL.splitWith (== 10) out |
| 172 | + -- Once Ficus supports file filtering we'll do this by passing the config file path into Ficus |
| 173 | + -- and Ficus will skip scanning the config file. But for now let's just filter post-scan |
| 174 | + parsedLines = mapMaybe decode messageLines |
| 175 | + messages = map singletonFicusMessage parsedLines |
| 176 | + |
| 177 | +-- add a FicusMessage to the corresponding entry of an empty FicusMessages |
| 178 | +singletonFicusMessage :: FicusMessage -> FicusMessages |
| 179 | +singletonFicusMessage message = case message of |
| 180 | + FicusMessageFinding msg -> mempty{ficusMessageFindings = [msg]} |
| 181 | + FicusMessageDebug msg -> mempty{ficusMessageDebugs = [msg]} |
| 182 | + FicusMessageError msg -> mempty{ficusMessageErrors = [msg]} |
0 commit comments