Split the import and insertion of advisories

ghc-tags.yaml

@@ -5,6 +5,7 @@ exclude_paths:
 - dist
 - dist-newstyle
 - assets
+- _build
 extensions:
 - BangPatterns
 - BlockArguments

src/advisories/Advisories/Import.hs

@@ -29,46 +29,58 @@ import Flora.Model.Release.Guard (guardThatReleaseExists)
 import Flora.Model.Release.Types
 import OSV.Reference.Orphans
 
--- | List deduplicated parsed Advisories
-importAdvisories
-  :: ( DB :> es
-     , Trace :> es
+processAdvisories
+  :: ( Trace :> es
      , IOE :> es
+     , DB :> es
      , Error (NonEmpty AdvisoryImportError) :> es
      )
   => FilePath
   -> Eff es ()
+processAdvisories root = do
+  importResult <- importAdvisories root
+  case importResult of
+    Failure failures ->
+      throwError failures
+    Success advisories ->
+      forM_ advisories $ \advisory -> processAdvisory advisory
+
+-- | List deduplicated parsed Advisories
+importAdvisories
+  :: ( Trace :> es
+     , IOE :> es
+     )
+  => FilePath
+  -> Eff es (Validation (NonEmpty AdvisoryImportError) (Vector Advisory))
 importAdvisories root = Tracing.rootSpan alwaysSampled "import-advisories" $ do
   result <- Tracing.childSpan "listAdvisories" $ listAdvisories root
   case result of
     Failure failures ->
-      let errors = case NonEmpty.nonEmpty failures of
-            Just nonEmptyFailures -> fmap AdvisoryParsingError nonEmptyFailures
-            Nothing -> NonEmpty.singleton FackinHell
-       in throwError errors
-    Success advisoryList -> do
-      forM_ advisoryList $ \advisory -> importAdvisory advisory
+      case NonEmpty.nonEmpty failures of
+        Just nonEmptyFailures -> pure $ Failure (fmap AdvisoryParsingError nonEmptyFailures)
+        Nothing -> error $ "Could not convert list of failures to non-empty: " <> show failures
+    Success advisoryList -> pure $ Success $ Vector.fromList advisoryList
 
-importAdvisory
+processAdvisory
   :: ( DB :> es
      , Trace :> es
      , IOE :> es
      , Error (NonEmpty AdvisoryImportError) :> es
      )
   => Advisory
   -> Eff es ()
-importAdvisory advisory = do
+processAdvisory advisory = do
   advisoryId <- AdvisoryId <$> liftIO UUID.nextRandom
   let advisoryAffectedPackages = Vector.fromList advisory.advisoryAffected
-  let advisoryDAO = processAdvisory advisoryId advisory
+  let advisoryDAO = mkAdvisory advisoryId advisory
   Update.insertAdvisory advisoryDAO
   processAffectedPackages advisoryId advisoryAffectedPackages
 
-processAdvisory
+mkAdvisory
   :: AdvisoryId
   -> Advisory
   -> AdvisoryDAO
-processAdvisory advisoryId advisory =
+mkAdvisory advisoryId advisory =
   AdvisoryDAO
     { advisoryId = advisoryId
     , hsecId = advisory.advisoryId
@@ -113,7 +125,7 @@ processAffectedPackage advisoryId affected = do
         case affected.affectedComponentIdentifier of
           Hackage affectedPackageName -> PackageName affectedPackageName
           GHC _ -> PackageName "ghc"
-  let namespace = chooseNamespace packageName "hackage" Set.empty
+  let namespace = chooseNamespace packageName ("hackage", Set.empty)
   package <- guardThatPackageExists namespace packageName $ \_ _ ->
     throwError (NonEmpty.singleton $ AffectedPackageNotFound namespace packageName)
   let declarations =
@@ -154,8 +166,8 @@ processAffectedVersionRanges affectedPackageId packageId affectedVersions = do
         mFixedReleaseId <- case affectedVersion.affectedVersionRangeFixed of
           Nothing -> pure Nothing
           Just version -> do
-            release <- guardThatReleaseExists packageId version $ \version ->
-              throwError (NonEmpty.singleton $ AffectedVersionNotFound packageId version)
+            release <- guardThatReleaseExists packageId version $ \releaseVersion ->
+              throwError (NonEmpty.singleton $ AffectedVersionNotFound packageId releaseVersion)
             pure $ Just release.releaseId
         let versionRangeDAO =
               AffectedVersionRangeDAO

src/advisories/Advisories/Import/Error.hs

@@ -10,5 +10,4 @@ data AdvisoryImportError
   = AffectedPackageNotFound Namespace PackageName
   | AdvisoryParsingError (FilePath, ParseAdvisoryError)
   | AffectedVersionNotFound PackageId Version
-  | FackinHell
   deriving stock (Eq, Show, Generic)