Allow fossa vps analyze metadata

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 ()

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

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
+  }

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"

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 ()

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

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