diff --git a/src/App/Fossa/Analyze.hs b/src/App/Fossa/Analyze.hs index b2b0afa71..de163ef7b 100644 --- a/src/App/Fossa/Analyze.hs +++ b/src/App/Fossa/Analyze.hs @@ -11,7 +11,7 @@ module App.Fossa.Analyze import App.Fossa.Analyze.GraphMangler (graphingToGraph) import App.Fossa.Analyze.Project (ProjectResult(..), mkResult) -import App.Fossa.FossaAPIV1 (ProjectMetadata, UploadResponse (..), uploadAnalysis, uploadContributors) +import App.Fossa.FossaAPIV1 (UploadResponse (..), uploadAnalysis, uploadContributors) import App.Fossa.ProjectInference (inferProject, mergeOverride) import App.Types import qualified Control.Carrier.Diagnostics as Diag @@ -76,7 +76,7 @@ import Types import VCS.Git (fetchGitContributors) data ScanDestination - = UploadScan URI ApiKey ProjectMetadata -- ^ upload to fossa with provided api key and base url + = UploadScan UploadInfo -- ^ upload to fossa with provided api key and base url | OutputStdout analyzeMain :: BaseDir -> Severity -> ScanDestination -> OverrideProject -> Bool -> [BuildTargetFilter] -> IO () @@ -173,7 +173,7 @@ analyze basedir destination override unpackArchives filters = do case destination of OutputStdout -> logStdout $ pretty (decodeUtf8 (Aeson.encode (buildResult projectResults))) - UploadScan baseurl apiKey metadata -> do + UploadScan UploadInfo {..} -> do revision <- mergeOverride override <$> inferProject (unBaseDir basedir) logInfo "" @@ -182,7 +182,7 @@ analyze basedir destination override unpackArchives filters = do let branchText = fromMaybe "No branch (detached HEAD)" $ projectBranch revision logInfo ("Using branch: `" <> pretty branchText <> "`") - uploadResult <- Diag.runDiagnostics $ uploadAnalysis basedir baseurl apiKey revision metadata projectResults + uploadResult <- Diag.runDiagnostics $ uploadAnalysis basedir uploadUri uploadApiKey revision uploadMetadata projectResults case uploadResult of Left failure -> logError (Diag.renderFailureBundle failure) Right success -> do @@ -191,13 +191,13 @@ analyze basedir destination override unpackArchives filters = do [ "============================================================" , "" , " View FOSSA Report:" - , " " <> pretty (fossaProjectUrl baseurl (uploadLocator resp) revision) + , " " <> pretty (fossaProjectUrl uploadUri (uploadLocator resp) revision) , "" , "============================================================" ] traverse_ (\err -> logError $ "FOSSA error: " <> viaShow err) (uploadError resp) - contribResult <- Diag.runDiagnostics $ runExecIO $ tryUploadContributors (unBaseDir basedir) baseurl apiKey $ uploadLocator resp + contribResult <- Diag.runDiagnostics $ runExecIO $ tryUploadContributors (unBaseDir basedir) uploadUri uploadApiKey $ uploadLocator resp case contribResult of Left failure -> logDebug (Diag.renderFailureBundle failure) Right _ -> pure () diff --git a/src/App/Fossa/FossaAPIV1.hs b/src/App/Fossa/FossaAPIV1.hs index 635e39d21..aa5a3afdf 100644 --- a/src/App/Fossa/FossaAPIV1.hs +++ b/src/App/Fossa/FossaAPIV1.hs @@ -8,7 +8,7 @@ module App.Fossa.FossaAPIV1 ( uploadAnalysis , uploadContributors , UploadResponse(..) - , ProjectMetadata(..) + , mkMetadataOpts , FossaError(..) , FossaReq(..) , Contributors(..) @@ -120,15 +120,6 @@ instance ToDiagnostic FossaError where OtherError err -> "An unknown error occurred when accessing the FOSSA API: " <> viaShow err BadURI uri -> "Invalid FOSSA URL: " <> pretty (URI.render uri) -data ProjectMetadata = ProjectMetadata - { projectTitle :: Maybe Text - , projectUrl :: Maybe Text - , projectJiraKey :: Maybe Text - , projectLink :: Maybe Text - , projectTeam :: Maybe Text - , projectPolicy :: Maybe Text - } deriving (Eq, Ord, Show) - uploadAnalysis :: (Has (Lift IO) sig m, Has Diagnostics sig m) => BaseDir -- ^ root directory for analysis @@ -153,7 +144,6 @@ uploadAnalysis rootDir baseUri key ProjectRevision{..} metadata projects = fossa opts = "locator" =: renderLocator (Locator "custom" projectName (Just projectRevision)) <> "v" =: cliVersion <> "managedBuild" =: True - <> "title" =: fromMaybe projectName (projectTitle metadata) <> apiHeader key <> mkMetadataOpts metadata -- Don't include branch if it doesn't exist, core may not handle empty string properly. @@ -168,6 +158,7 @@ mkMetadataOpts ProjectMetadata{..} = mconcat $ catMaybes , ("link" =:) <$> projectLink , ("team" =:) <$> projectTeam , ("policy" =:) <$> projectPolicy + , ("title" =:) <$> projectTitle ] mangleError :: HttpException -> FossaError diff --git a/src/App/Fossa/Main.hs b/src/App/Fossa/Main.hs index c82946916..4958f9f14 100644 --- a/src/App/Fossa/Main.hs +++ b/src/App/Fossa/Main.hs @@ -7,7 +7,6 @@ module App.Fossa.Main where import App.Fossa.Analyze (ScanDestination (..), analyzeMain) -import App.Fossa.FossaAPIV1 (ProjectMetadata (..)) import App.Fossa.ListTargets (listTargetsMain) import App.Fossa.Report (ReportType (..), reportMain) import App.Fossa.Test (TestOutputType (..), testMain) @@ -59,7 +58,7 @@ appMain = do then analyzeMain baseDir logSeverity OutputStdout analyzeOverride analyzeUnpackArchives analyzeBuildTargetFilters else do key <- requireKey maybeApiKey - analyzeMain baseDir logSeverity (UploadScan optBaseUrl key analyzeMetadata) analyzeOverride analyzeUnpackArchives analyzeBuildTargetFilters + analyzeMain baseDir logSeverity (UploadScan $ UploadInfo optBaseUrl key analyzeMetadata) analyzeOverride analyzeUnpackArchives analyzeBuildTargetFilters TestCommand TestOptions {..} -> do baseDir <- validateDir testBaseDir @@ -85,7 +84,8 @@ appMain = do case vpsCommand of VPSAnalyzeCommand VPSAnalyzeOptions {..} -> do baseDir <- validateDir vpsAnalyzeBaseDir - scanMain optBaseUrl baseDir apikey logSeverity override vpsFileFilter (SkipIPRScan skipIprScan) + let uploadInfo = UploadInfo optBaseUrl apikey vpsAnalyzeMeta + scanMain baseDir logSeverity uploadInfo override vpsFileFilter (SkipIPRScan skipIprScan) NinjaGraphCommand ninjaGraphOptions -> do ninjaGraphMain optBaseUrl apikey logSeverity override ninjaGraphOptions @@ -219,7 +219,7 @@ vpsOpts = VPSOptions <$> skipIprScanOpt <*> fileFilterOpt <*> vpsCommands fileFilterOpt = FilterExpressions <$> jsonOption (long "ignore-file-regex" <> short 'i' <> metavar "REGEXPS" <> help "JSON encoded array of regular expressions used to filter scanned paths" <> value []) vpsAnalyzeOpts :: Parser VPSAnalyzeOptions -vpsAnalyzeOpts = VPSAnalyzeOptions <$> baseDirArg +vpsAnalyzeOpts = VPSAnalyzeOptions <$> baseDirArg <*> metadataOpts ninjaGraphOpts :: Parser NinjaGraphCLIOptions ninjaGraphOpts = NinjaGraphCLIOptions <$> baseDirArg <*> ninjaDepsOpt <*> lunchTargetOpt <*> scanIdOpt <*> buildNameOpt @@ -294,5 +294,7 @@ data VPSOptions = VPSOptions vpsCommand :: VPSCommand } -newtype VPSAnalyzeOptions = VPSAnalyzeOptions - { vpsAnalyzeBaseDir :: FilePath } +data VPSAnalyzeOptions = VPSAnalyzeOptions + { vpsAnalyzeBaseDir :: FilePath, + vpsAnalyzeMeta :: ProjectMetadata + } diff --git a/src/App/Fossa/VPS/Scan.hs b/src/App/Fossa/VPS/Scan.hs index c08752bec..98cb5c7be 100644 --- a/src/App/Fossa/VPS/Scan.hs +++ b/src/App/Fossa/VPS/Scan.hs @@ -18,21 +18,20 @@ import App.Fossa.VPS.Scan.RunSherlock import App.Fossa.VPS.Scan.ScotlandYard import App.Fossa.VPS.Types import App.Fossa.ProjectInference -import App.Types (BaseDir (..), ApiKey (..), OverrideProject (..), ProjectRevision (..)) +import App.Types (BaseDir (..), ApiKey (..), OverrideProject (..), ProjectRevision (..), UploadInfo (..), ProjectMetadata (..)) import Data.Aeson import Data.Text (Text) import Effect.Logger import Path -import Text.URI (URI) newtype SkipIPRScan = SkipIPRScan {unSkipIPRScan :: Bool} -scanMain :: URI -> BaseDir -> ApiKey -> Severity -> OverrideProject -> FilterExpressions -> SkipIPRScan -> IO () -scanMain baseuri basedir apikey logSeverity overrideProject fileFilters skipIprScan = do - let fossaOpts = FossaOpts baseuri $ unApiKey apikey +scanMain :: BaseDir -> Severity -> UploadInfo -> OverrideProject -> FilterExpressions -> SkipIPRScan -> IO () +scanMain basedir logSeverity UploadInfo {..} overrideProject fileFilters skipIprScan = do + let fossaOpts = FossaOpts uploadUri $ unApiKey uploadApiKey partVpsOpts = PartialVPSOpts fossaOpts (unSkipIPRScan skipIprScan) fileFilters - result <- runDiagnostics $ withEmbeddedBinaries $ vpsScan basedir logSeverity overrideProject partVpsOpts + result <- runDiagnostics $ withEmbeddedBinaries $ vpsScan basedir logSeverity overrideProject uploadMetadata partVpsOpts case result of Left failure -> do print $ renderFailureBundle failure @@ -44,8 +43,8 @@ scanMain baseuri basedir apikey logSeverity overrideProject fileFilters skipIprS vpsScan :: ( Has Diagnostics sig m , Has (Lift IO) sig m - ) => BaseDir -> Severity -> OverrideProject -> PartialVPSOpts -> BinaryPaths -> m () -vpsScan (BaseDir basedir) logSeverity overrideProject partVpsOpts binaryPaths = withLogQueue logSeverity $ \queue -> runLogger queue $ do + ) => BaseDir -> Severity -> OverrideProject -> ProjectMetadata -> PartialVPSOpts -> BinaryPaths -> m () +vpsScan (BaseDir basedir) logSeverity overrideProject projectMetadata partVpsOpts binaryPaths = withLogQueue logSeverity $ \queue -> runLogger queue $ do -- Build the revision ProjectRevision {..} <- mergeOverride overrideProject <$> inferProject basedir @@ -68,7 +67,7 @@ vpsScan (BaseDir basedir) logSeverity overrideProject partVpsOpts binaryPaths = -- Create scan in Core logDebug "[All] Creating project in FOSSA" - _ <- context "creating project in FOSSA" $ createCoreProject vpsProjectName projectRevision fossa + _ <- context "creating project in FOSSA" $ createCoreProject vpsProjectName projectRevision projectMetadata fossa -- Create scan in SY logDebug "[All] Creating scan in Scotland Yard" diff --git a/src/App/Fossa/VPS/Scan/Core.hs b/src/App/Fossa/VPS/Scan/Core.hs index c696b4b98..85cd7d1f2 100644 --- a/src/App/Fossa/VPS/Scan/Core.hs +++ b/src/App/Fossa/VPS/Scan/Core.hs @@ -17,7 +17,10 @@ module App.Fossa.VPS.Scan.Core ) where +-- I REALLY don't like mixing these modules together. +import App.Fossa.FossaAPIV1 (mkMetadataOpts) import App.Fossa.VPS.Types +import App.Types (ProjectMetadata) import App.Util (parseUri) import Data.Text (pack, Text) import Prelude @@ -84,13 +87,14 @@ projectScanFiltersEndpoint baseurl locator = baseurl /: "api" /: "vendored-packa FIXME: Every function below this line is using a data structure designed for the CLI. This tightly couples us to our CLI API, and is very tedious to change with the merge of `vpscli` and `fossa` exe's. -} -createCoreProject :: (Has (Lift IO) sig m, Has Diagnostics sig m) => Text -> Text -> FossaOpts -> m () -createCoreProject name revision FossaOpts{..} = runHTTP $ do +createCoreProject :: (Has (Lift IO) sig m, Has Diagnostics sig m) => Text -> Text -> ProjectMetadata -> FossaOpts -> m () +createCoreProject name revision metadata FossaOpts{..} = runHTTP $ do let auth = coreAuthHeader fossaApiKey + let metaOpts = mkMetadataOpts metadata let body = object ["name" .= name, "revision" .= revision] (baseUrl, baseOptions) <- parseUri fossaUrl - _ <- req POST (createProjectEndpoint baseUrl) (ReqBodyJson body) ignoreResponse (baseOptions <> header "Content-Type" "application/json" <> auth) + _ <- req POST (createProjectEndpoint baseUrl) (ReqBodyJson body) ignoreResponse (baseOptions <> header "Content-Type" "application/json" <> auth <> metaOpts) pure () completeCoreProject :: (Has (Lift IO) sig m, Has Diagnostics sig m) => RevisionLocator -> FossaOpts -> m () diff --git a/src/App/Fossa/VPS/Types.hs b/src/App/Fossa/VPS/Types.hs index 095be893e..483d8b5a3 100644 --- a/src/App/Fossa/VPS/Types.hs +++ b/src/App/Fossa/VPS/Types.hs @@ -40,7 +40,7 @@ instance ToJSON FilterExpressions where -- FIXME: replace these with non-CLI types -- VPSOpts in particular is used as a God type, and is very unwieldy in the merged CLI form. -data FossaOpts = FossaOpts +data FossaOpts = FossaOpts -- FIXME: remove this type, use App.Types.UploadInfo instead. { fossaUrl :: URI , fossaApiKey :: Text } @@ -53,7 +53,7 @@ data PartialVPSOpts } data VPSOpts = VPSOpts - { fossa :: FossaOpts + { fossa :: FossaOpts -- FIXME: remove this field, keep upload info separate. , vpsProjectName :: Text , userProvidedRevision :: Maybe Text -- FIXME: Since we can now infer a revision, we should rename this field. , skipIprScan :: Bool diff --git a/src/App/Types.hs b/src/App/Types.hs index fda7f3001..81f2b1832 100644 --- a/src/App/Types.hs +++ b/src/App/Types.hs @@ -3,22 +3,40 @@ module App.Types BaseDir (..), NinjaGraphCLIOptions (..), OverrideProject (..), + ProjectMetadata (..), ProjectRevision (..), + UploadInfo (..), ) where import Data.Text (Text) +import Text.URI import Path newtype ApiKey = ApiKey {unApiKey :: Text} deriving (Eq, Ord, Show) newtype BaseDir = BaseDir {unBaseDir :: Path Abs Dir} deriving (Eq, Ord, Show) +data UploadInfo = UploadInfo + { uploadUri :: URI, + uploadApiKey :: ApiKey, + uploadMetadata :: ProjectMetadata + } + data OverrideProject = OverrideProject { overrideName :: Maybe Text, overrideRevision :: Maybe Text, overrideBranch :: Maybe Text } +data ProjectMetadata = ProjectMetadata + { projectTitle :: Maybe Text + , projectUrl :: Maybe Text + , projectJiraKey :: Maybe Text + , projectLink :: Maybe Text + , projectTeam :: Maybe Text + , projectPolicy :: Maybe Text + } deriving (Eq, Ord, Show) + data ProjectRevision = ProjectRevision { projectName :: Text , projectRevision :: Text