Add multiple libraries fixture and make sure every library is imported (

#181)

* Add a Cabal fixture with multiple public libraries

* Add ghc-tags config

* Test suite

* Fix the import of cabal info

app/cli/Main.hs

@@ -5,6 +5,7 @@ import Data.Password.Types
 import Data.Text (Text)
 import DesignSystem (generateComponents)
 import Effectful
+import Effectful.Log.Backend.StandardOutput qualified as Log
 import Effectful.PostgreSQL.Transact.Effect
 import Flora.Model.User.Query qualified as Query
 import GHC.Generics (Generic)
@@ -106,13 +107,12 @@ runOptions (Options (CreateUser opts)) = do
       let user = if canLogin then templateUser else templateUser & #userFlags % #canLogin .~ False
       insertUser user
 runOptions (Options GenDesignSystemComponents) = generateComponents
-runOptions (Options (ImportPackages path)) = do
-  importFolderOfCabalFiles path
+runOptions (Options (ImportPackages path)) = importFolderOfCabalFiles path
 
 importFolderOfCabalFiles :: ([DB, IOE] :>> es) => FilePath -> Eff es ()
-importFolderOfCabalFiles path = do
+importFolderOfCabalFiles path = Log.withStdOutLogger $ \appLogger -> do
   user <- fromJust <$> Query.getUserByUsername "hackage-user"
-  importAllFilesInRelativeDirectory (user ^. #userId) path
+  importAllFilesInRelativeDirectory appLogger (user ^. #userId) path
 
 withInfo :: Parser a -> String -> ParserInfo a
 withInfo opts desc = info (helper <*> opts) $ progDesc desc

flora.cabal

@@ -322,6 +322,7 @@ test-suite flora-test
     , flora
     , hedgehog
     , http-client            ==0.7.10
+    , log-effectful
     , network-uri
     , optics-core
     , password

ghc-tags.yaml

@@ -0,0 +1,25 @@
+source_paths:
+- .
+exclude_paths:
+- .stack-work
+- dist
+- dist-newstyle
+language: Haskell2010
+extensions:
+- BangPatterns
+- BlockArguments
+- CApiFFI
+- ExplicitForAll
+- ExplicitNamespaces
+- GADTSyntax
+- LambdaCase
+- MultiWayIf
+- NumericUnderscores
+- OverloadedLabels
+- PatternSynonyms
+- TypeApplications
+- UnicodeSyntax
+- ImportQualifiedPost
+cpp_includes: []
+cpp_options: []
+

src/Flora/Import/Package.hs

@@ -49,8 +49,11 @@ import Distribution.Types.TestSuite
 import Distribution.Utils.ShortText qualified as Cabal
 import Effectful
 import Effectful.Internal.Monad (unsafeEff_)
+import Effectful.Log (Logging)
 import Effectful.PostgreSQL.Transact.Effect (DB)
+import Effectful.Time (Time)
 import GHC.Generics (Generic)
+import Log qualified
 import Optics.Core
 import System.Directory qualified as System
 import System.FilePath
@@ -130,21 +133,21 @@ coreLibraries =
    * finally, inserting that data into the database
 -}
 importFile ::
-  ([DB, IOE] :>> es) =>
+  ([DB, IOE, Logging, Time] :>> es) =>
   UserId ->
   -- | The absolute path to the Cabal file
   FilePath ->
   Eff es ()
 importFile userId path = loadFile path >>= extractPackageDataFromCabal userId >>= persistImportOutput
 
-importRelFile :: ([DB, IOE] :>> es) => UserId -> FilePath -> Eff es ()
+importRelFile :: ([DB, IOE, Logging, Time] :>> es) => UserId -> FilePath -> Eff es ()
 importRelFile user dir = do
   workdir <- (</> dir) <$> liftIO System.getCurrentDirectory
   importFile user workdir
 
 -- | Loads and parses a Cabal file
 loadFile ::
-  ([DB, IOE] :>> es) =>
+  ([DB, IOE, Logging, Time] :>> es) =>
   -- | The absolute path to the Cabal file
   FilePath ->
   Eff es GenericPackageDescription
@@ -158,7 +161,7 @@ loadFile path = do
   parseString parseGenericPackageDescription path content
 
 parseString ::
-  HasCallStack =>
+  (HasCallStack, [Logging, Time] :>> es) =>
   -- | File contents to final value parser
   (BS.ByteString -> ParseResult a) ->
   -- | File name
@@ -169,10 +172,11 @@ parseString parser name bs = do
   let (_warnings, result) = runParseResult (parser bs)
   case result of
     Right x -> pure x
-    Left _ ->
+    Left err -> do
+      Log.logAttention_ (display $ show err)
       throw $ CabalFileCouldNotBeParsed name
 
-loadAndExtractCabalFile :: ([DB, IOE] :>> es) => UserId -> FilePath -> Eff es ImportOutput
+loadAndExtractCabalFile :: ([DB, IOE, Logging, Time] :>> es) => UserId -> FilePath -> Eff es ImportOutput
 loadAndExtractCabalFile userId filePath = loadFile filePath >>= extractPackageDataFromCabal userId
 
 {- | Persists an 'ImportOutput' to the database. An 'ImportOutput' can be obtained
@@ -194,7 +198,7 @@ persistImportOutput (ImportOutput package categories release components) = do
 
     persistComponent (packageComponent, deps) = do
       liftIO . T.putStrLn $
-        "🧩  Persisting component: " <> display (packageComponent.canonicalForm) <> " with " <> display (length deps) <> " 🔗 dependencies."
+        "🧩  Persisting component: " <> display (packageComponent.canonicalForm) <> " with " <> display (length deps) <> " dependencies."
       Update.upsertPackageComponent packageComponent
       traverse_ persistImportDependency deps
 
@@ -255,24 +259,26 @@ extractPackageDataFromCabal userId genericDesc = do
           , updatedAt = timestamp
           }
 
-  let libs = extractLibrary package release Nothing Nothing <$> allLibraries packageDesc
-  let condLibs = maybe [] (extractCondTree extractLibrary package release Nothing) (genericDesc.condLibrary)
+  let lib = extractLibrary package release Nothing Nothing <$> allLibraries packageDesc
+  let condLib = maybe [] (extractCondTree extractLibrary package release Nothing) (genericDesc.condLibrary)
+  let condSubLibs = extractCondTrees extractLibrary package release genericDesc.condSubLibraries
 
   let foreignLibs = extractForeignLib package release Nothing Nothing <$> packageDesc.foreignLibs
-  let condForeignLibs = extractCondTrees extractForeignLib package release $ genericDesc.condForeignLibs
+  let condForeignLibs = extractCondTrees extractForeignLib package release genericDesc.condForeignLibs
 
   let executables = extractExecutable package release Nothing Nothing <$> packageDesc.executables
-  let condExecutables = extractCondTrees extractExecutable package release $ genericDesc.condExecutables
+  let condExecutables = extractCondTrees extractExecutable package release genericDesc.condExecutables
 
   let testSuites = extractTestSuite package release Nothing Nothing <$> packageDesc.testSuites
-  let condTestSuites = extractCondTrees extractTestSuite package release $ genericDesc.condTestSuites
+  let condTestSuites = extractCondTrees extractTestSuite package release genericDesc.condTestSuites
 
   let benchmarks = extractBenchmark package release Nothing Nothing <$> packageDesc.benchmarks
-  let condBenchmarks = extractCondTrees extractBenchmark package release $ genericDesc.condBenchmarks
+  let condBenchmarks = extractCondTrees extractBenchmark package release genericDesc.condBenchmarks
 
   let components =
-        libs
-          <> condLibs
+        lib
+          <> condLib
+          <> condSubLibs
           <> executables
           <> condExecutables
           <> foreignLibs
@@ -283,16 +289,7 @@ extractPackageDataFromCabal userId genericDesc = do
           <> condBenchmarks
   pure ImportOutput{..}
 
-type ComponentExtractor component =
-  Package ->
-  Release ->
-  Maybe UnqualComponentName ->
-  -- | An optional component condition (not used at the moment)
-  Maybe (Condition ConfVar) ->
-  component ->
-  ImportComponent
-
-extractLibrary :: ComponentExtractor Library
+extractLibrary :: Package -> Release -> Maybe UnqualComponentName -> Maybe (Condition ConfVar) -> Library -> ImportComponent
 extractLibrary package =
   genericComponentExtractor
     Component.Library
@@ -304,29 +301,29 @@ extractLibrary package =
     getLibName LMainLibName = display (package.name)
     getLibName (LSubLibName lname) = T.pack $ unUnqualComponentName lname
 
-extractForeignLib :: ComponentExtractor ForeignLib
+extractForeignLib :: Package -> Release -> Maybe UnqualComponentName -> Maybe (Condition ConfVar) -> ForeignLib -> ImportComponent
 extractForeignLib package =
   genericComponentExtractor
     Component.ForeignLib
     (^. #foreignLibName % to unUnqualComponentName % to T.pack)
     (^. #foreignLibBuildInfo % #targetBuildDepends)
     package
 
-extractExecutable :: ComponentExtractor Executable
+extractExecutable :: Package -> Release -> Maybe UnqualComponentName -> Maybe (Condition ConfVar) -> Executable -> ImportComponent
 extractExecutable =
   genericComponentExtractor
     Component.Executable
     (^. #exeName % to unUnqualComponentName % to T.pack)
     (^. #buildInfo % #targetBuildDepends)
 
-extractTestSuite :: ComponentExtractor TestSuite
+extractTestSuite :: Package -> Release -> Maybe UnqualComponentName -> Maybe (Condition ConfVar) -> TestSuite -> ImportComponent
 extractTestSuite =
   genericComponentExtractor
     Component.TestSuite
     (^. #testName % to unUnqualComponentName % to T.pack)
     (^. #testBuildInfo % #targetBuildDepends)
 
-extractBenchmark :: ComponentExtractor Benchmark
+extractBenchmark :: Package -> Release -> Maybe UnqualComponentName -> Maybe (Condition ConfVar) -> Benchmark -> ImportComponent
 extractBenchmark =
   genericComponentExtractor
     Component.Benchmark
@@ -337,7 +334,7 @@ extractBenchmark =
  to every node, returning a list of 'ImportComponent'
 -}
 extractCondTree ::
-  ComponentExtractor component ->
+  (Package -> Release -> Maybe UnqualComponentName -> Maybe (Condition ConfVar) -> component -> ImportComponent) ->
   Package ->
   Release ->
   Maybe UnqualComponentName ->
@@ -359,7 +356,7 @@ extractCondTree extractor package release defaultComponentName = go Nothing
  from a 'GenericPackageDescription'
 -}
 extractCondTrees ::
-  ComponentExtractor component ->
+  (Package -> Release -> Maybe UnqualComponentName -> Maybe (Condition ConfVar) -> component -> ImportComponent) ->
   Package ->
   Release ->
   [(UnqualComponentName, CondTree ConfVar [Dependency] component)] ->
@@ -368,12 +365,19 @@ extractCondTrees extractor package release trees =
   trees >>= \case (name, tree) -> extractCondTree extractor package release (Just name) tree
 
 genericComponentExtractor ::
+  forall component.
+  () =>
   ComponentType ->
   -- | Extract name from component
   (component -> Text) ->
   -- | Extract dependencies
   (component -> [Dependency]) ->
-  ComponentExtractor component
+  Package ->
+  Release ->
+  Maybe UnqualComponentName ->
+  Maybe (Condition ConfVar) ->
+  component ->
+  (PackageComponent, [ImportDependency])
 genericComponentExtractor
   componentType
   getName
@@ -384,7 +388,7 @@ genericComponentExtractor
   condition
   rawComponent =
     let releaseId = release.releaseId
-        componentName = maybe (getName rawComponent) (T.pack . unUnqualComponentName) defaultComponentName
+        componentName = maybe (getName rawComponent) display defaultComponentName
         canonicalForm = CanonicalComponent{..}
         componentId = deterministicComponentId releaseId canonicalForm
         metadata = ComponentMetadata (ComponentCondition <$> condition)

src/Flora/Import/Package/Bulk.hs

@@ -8,7 +8,10 @@ import Data.Foldable (traverse_)
 import Data.Function
 import Data.List (isSuffixOf)
 import Effectful
+import Effectful.Log qualified as Log
 import Effectful.PostgreSQL.Transact.Effect (DB, getPool, runDB)
+import Effectful.Time
+import Log (Logger, defaultLogLevel)
 import Streaming (chunksOf)
 import Streaming.Prelude (Of, Stream)
 import Streaming.Prelude qualified as Str
@@ -21,20 +24,20 @@ import Flora.Model.Release.Update qualified as Update
 import Flora.Model.User
 
 -- | Same as 'importAllFilesInDirectory' but accepts a relative path to the current working directory
-importAllFilesInRelativeDirectory :: [DB, IOE] :>> es => UserId -> FilePath -> Eff es ()
-importAllFilesInRelativeDirectory user dir = do
+importAllFilesInRelativeDirectory :: [DB, IOE] :>> es => Logger -> UserId -> FilePath -> Eff es ()
+importAllFilesInRelativeDirectory appLogger user dir = do
   workdir <- (</> dir) <$> liftIO System.getCurrentDirectory
-  importAllFilesInDirectory user workdir
+  importAllFilesInDirectory appLogger user workdir
 
 -- | Finds all cabal files in the specified directory, and inserts them into the database after extracting the relevant data
-importAllFilesInDirectory :: ([DB, IOE] :>> es) => UserId -> FilePath -> Eff es ()
-importAllFilesInDirectory user dir = do
+importAllFilesInDirectory :: ([DB, IOE] :>> es) => Logger -> UserId -> FilePath -> Eff es ()
+importAllFilesInDirectory appLogger user dir = do
   pool <- getPool
   parallelWorkers <- liftIO getNumCapabilities
   let chunkSize = 200
   countMVar <- liftIO $ newMVar @Int 0
   findAllCabalFilesInDirectory dir
-    & parMapM parallelWorkers (runEff . runDB pool . loadAndExtractCabalFile user)
+    & parMapM parallelWorkers (runEff . runDB pool . runCurrentTimeIO . Log.runLogging "flora-jobs" appLogger defaultLogLevel . loadAndExtractCabalFile user)
     & chunksOf chunkSize
     & Str.mapped Str.toList
     & Str.mapM_ (persistChunk countMVar)

src/Flora/Model/Package/Component.hs

@@ -56,7 +56,7 @@ data ComponentType
   | TestSuite
   | Benchmark
   | ForeignLib
-  deriving stock (Eq, Show, Generic, Bounded, Enum)
+  deriving stock (Eq, Ord, Show, Generic, Bounded, Enum)
 
 instance Display ComponentType where
   displayBuilder Library = "library"
@@ -85,7 +85,7 @@ data CanonicalComponent = CanonicalComponent
   { componentName :: Text
   , componentType :: ComponentType
   }
-  deriving stock (Eq, Show, Generic)
+  deriving stock (Eq, Ord, Show, Generic)
 
 instance Display CanonicalComponent where
   displayBuilder CanonicalComponent{componentName, componentType} = displayBuilder componentType <> ":" <> B.fromText componentName

src/Flora/Model/Release/Orphans.hs

@@ -22,6 +22,7 @@ import Distribution.Parsec
 import Distribution.Pretty (prettyShow)
 import Distribution.Pretty qualified as Pretty
 import Distribution.SPDX.License qualified as SPDX
+import Distribution.Types.UnqualComponentName (UnqualComponentName, unUnqualComponentName)
 import Distribution.Types.Version
 import Distribution.Types.Version qualified as Cabal
 import Distribution.Utils.Generic (fromUTF8BS)
@@ -63,3 +64,6 @@ instance FromField SPDX.License where
 
 instance ToField SPDX.License where
   toField = Escape . C8.pack . Pretty.prettyShow
+
+instance Display UnqualComponentName where
+  displayBuilder = Builder.fromString . unUnqualComponentName

src/Flora/Model/Release/Types.hs

@@ -23,7 +23,7 @@ import Lucid qualified
 
 newtype ReleaseId = ReleaseId {getReleaseId :: UUID}
   deriving
-    (Eq, Show, FromField, ToField, FromJSON, ToJSON)
+    (Eq, Ord, Show, FromField, ToField, FromJSON, ToJSON)
     via UUID
   deriving
     (Display)

src/Flora/Model/User/Query.hs

@@ -13,7 +13,7 @@ import Effectful
 import Effectful.PostgreSQL.Transact.Effect
 import Flora.Model.User
 
-getUserById :: (DB :> es, IOE :> es) => UserId -> Eff es (Maybe User)
+getUserById :: (DB :> es) => UserId -> Eff es (Maybe User)
 getUserById userId = dbtToEff $ selectById (Only userId)
 
 getUserByUsername :: ([DB, IOE] :>> es) => Text -> Eff es (Maybe User)