Skip to content

Commit

Permalink
[FLORA-414] Store archive hashes
Browse files Browse the repository at this point in the history
  • Loading branch information
@tchoutri
tchoutri committed Jun 17, 2024
1 parent a1d175d commit 5eb0c64
Show file tree
Hide file tree
Showing 8 changed files with 227 additions and 85 deletions.
3 changes: 3 additions & 0 deletions migrations/20240617215020_make_archive_checksum_nullable.sql
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,3 @@
alter table releases
alter column archive_checksum drop not null;

178 changes: 128 additions & 50 deletions src/core/Flora/Import/Package.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -21,31 +21,54 @@ module Flora.Import.Package
( coreLibraries
, versionList
, loadContent
, loadAndExtractCabalFile
, persistImportOutput
, extractPackageDataFromCabal
, chooseNamespace
, loadJSONContent
, persistHashes
) where

import Control.DeepSeq (force)
import Control.Exception
import Control.Monad (forM_)
import Data.Aeson (object, (.=))
import Data.Aeson qualified as Aeson
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap qualified as KeyMap
import Data.ByteString qualified as BS
import Data.IORef (IORef)
import Data.IORef qualified as IORef
import Data.IORef qualified as IOref
import Data.List.NonEmpty qualified as NE
import Data.Map (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text, pack)
import Data.Text qualified as T
import Data.Text qualified as Text
import Data.Text.Display
import Data.Text.IO qualified as T
import Data.Text.Encoding qualified as Text
import Data.Text.IO qualified as Text
import Data.Time (UTCTime)
import Data.Vector (Vector)
import Data.Vector qualified as Vector
import Distribution.Compat.NonEmptySet (toList)
import Distribution.Compiler (CompilerFlavor (..))
import Distribution.Fields.ParseResult
import Distribution.PackageDescription (CondBranch (..), CondTree (condTreeData), Condition (CNot), ConfVar, UnqualComponentName, allLibraries, unPackageName, unUnqualComponentName)
import Distribution.PackageDescription
( CondBranch (..)
, CondTree (condTreeData)
, Condition (CNot)
, ConfVar
, UnqualComponentName
, allLibraries
, unPackageName
, unUnqualComponentName
)
import Distribution.PackageDescription qualified as Cabal hiding (PackageName)
import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
import Distribution.Parsec qualified as Parsec
import Distribution.Pretty
import Distribution.Types.Benchmark
import Distribution.Types.Dependency
Expand All @@ -61,7 +84,6 @@ import Distribution.Types.VersionRange (VersionRange, withinRange)
import Distribution.Utils.ShortText qualified as Cabal
import Distribution.Version qualified as Version
import Effectful
import Effectful.Internal.Monad (unsafeEff_)
import Effectful.Log (Log)
import Effectful.Poolboy (Poolboy)
import Effectful.Poolboy qualified as Poolboy
Expand All @@ -71,20 +93,20 @@ import Effectful.Time qualified as Time
import GHC.List (List)
import Log qualified
import Optics.Core
import System.Directory qualified as System
import System.Exit (exitFailure)
import System.FilePath qualified as FilePath

import Control.Monad (forM_, unless)
import Data.Aeson (object, (.=))
import Data.List.NonEmpty qualified as NE
import Flora.Import.Categories.Tuning qualified as Tuning
import Flora.Import.Package.Types
import Flora.Import.Types
import Flora.Model.Category.Update qualified as Update
import Flora.Model.Component.Types as Component
import Flora.Model.Package.Orphans ()
import Flora.Model.Package.Query qualified as Query
import Flora.Model.Package.Types
import Flora.Model.Package.Update qualified as Update
import Flora.Model.Release (deterministicReleaseId)
import Flora.Model.Release.Query qualified as Query
import Flora.Model.Release.Types
import Flora.Model.Release.Update qualified as Update
import Flora.Model.Requirement
Expand Down Expand Up @@ -181,26 +203,53 @@ versionList =
, Version.mkVersion [7, 10, 3]
]

-- | Loads and parses a Cabal file
loadFile
:: (IOE :> es, Log :> es)
=> FilePath
-- ^ The absolute path to the Cabal file
-> Eff es (UTCTime, GenericPackageDescription)
loadFile path = do
exists <- liftIO $ System.doesFileExist path
unless exists $
unsafeEff_ $
throwIO $
CabalFileNotFound path
content <- liftIO $ BS.readFile path
timestamp <- liftIO $ System.getModificationTime path
descr <- loadContent path content
pure (timestamp, descr)

loadContent :: Log :> es => String -> BS.ByteString -> Eff es GenericPackageDescription
loadContent :: Log :> es => FilePath -> BS.ByteString -> Eff es GenericPackageDescription
loadContent = parseString parseGenericPackageDescription

loadJSONContent
:: (Log :> es, IOE :> es)
=> FilePath
-> BS.ByteString
-> (Text, Set PackageName)
-> Eff es (PackageName, Namespace, Version, Target)
loadJSONContent path content (repositoryName, repositoryPackages) = do
case getNameAndVersionFromPath path of
Nothing -> do
Log.logAttention "parse error" $
object ["path" .= path]
error "Parse error"
Just (name, versionText) -> do
let (mReleaseJSON :: Maybe ReleaseJSONFile) = Aeson.decodeStrict' content
let field = "<repo>/package/" <> name <> "-" <> versionText <> ".tar.gz"
case mReleaseJSON of
Nothing -> do
Log.logAttention "Could not parse JSON" $
object ["json" .= Text.decodeUtf8 content]
liftIO exitFailure
Just releaseJSON -> do
let mTarget = KeyMap.lookup (Key.fromText field) releaseJSON.signed.targets
case mTarget of
Nothing -> do
Log.logAttention ("Could not find field: " <> field) $
object ["json" .= releaseJSON]
liftIO exitFailure
Just target -> do
case Parsec.simpleParsec $ Text.unpack versionText of
Nothing -> do
Log.logAttention "Could not parse version" $
object ["version" .= versionText, "package" .= name]
error ":("
Just version -> do
let packageName = PackageName name
let chosenNamespace = chooseNamespace packageName repositoryName repositoryPackages
pure (packageName, chosenNamespace, version, target)

getNameAndVersionFromPath :: FilePath -> Maybe (Text, Text)
getNameAndVersionFromPath path =
case Text.split (== '/') $ Text.pack $ FilePath.takeDirectory path of
[name, versionText] -> Just (name, versionText)
_ -> Nothing

parseString
:: Log :> es
=> (BS.ByteString -> ParseResult a)
Expand All @@ -217,21 +266,11 @@ parseString parser name bs = do
Log.logAttention_ (display $ show err)
throw $ CabalFileCouldNotBeParsed name

loadAndExtractCabalFile
:: (IOE :> es, Log :> es, Time :> es)
=> UserId
-> FilePath
-> (Text, Set PackageName)
-> Eff es ImportOutput
loadAndExtractCabalFile userId filePath repo =
loadFile filePath
>>= uncurry (extractPackageDataFromCabal userId repo)

-- | Persists an 'ImportOutput' to the database. An 'ImportOutput' can be obtained
-- by extracting relevant information from a Cabal file using 'extractPackageDataFromCabal'
persistImportOutput :: forall es. (Poolboy :> es, DB :> es, IOE :> es) => ImportOutput -> Eff es ()
persistImportOutput (ImportOutput package categories release components) = do
liftIO . T.putStrLn $ "📦 Persisting package: " <> packageName <> ", 🗓 Release v" <> display release.version
liftIO . Text.putStrLn $ "📦 Persisting package: " <> packageName <> ", 🗓 Release v" <> display release.version
persistPackage
Update.upsertRelease release
parallelRun persistComponent components
Expand All @@ -247,7 +286,7 @@ persistImportOutput (ImportOutput package categories release components) = do

persistComponent :: (PackageComponent, List ImportDependency) -> Eff es ()
persistComponent (packageComponent, deps) = do
liftIO . T.putStrLn $
liftIO . Text.putStrLn $
"🧩 Persisting component: "
<> display packageComponent.canonicalForm
<> " with "
Expand All @@ -261,17 +300,49 @@ persistImportOutput (ImportOutput package categories release components) = do
Update.upsertPackage dep.package
Update.upsertRequirement dep.requirement

persistHashes
:: (DB :> es, IOE :> es, Log :> es)
=> IORef (Map (Namespace, PackageName) Text)
-> (PackageName, Namespace, Version, Target)
-> Eff es ()
persistHashes tarballHashIORef (packageName, namespace, version, target) = do
mPackage <- Query.getPackageByNamespaceAndName namespace packageName
case mPackage of
Just package -> do
mRelease <- Query.getReleaseByVersion package.packageId version
case mRelease of
Nothing -> do
Log.logInfo_ "Release does not exist, putting the hash in an ioref"
persisHashInMemory tarballHashIORef (namespace, packageName) target.hashes.sha256
Just release -> Update.setArchiveChecksum release.releaseId target.hashes.sha256
Nothing -> do
Log.logInfo_ "Package does not exist, putting the hash in an ioref"
persisHashInMemory tarballHashIORef (namespace, packageName) target.hashes.sha256

persisHashInMemory
:: IOE :> es
=> IORef (Map (Namespace, PackageName) Text)
-> (Namespace, PackageName)
-> Text
-> Eff es ()
persisHashInMemory tarballHashIORef key hash =
liftIO $
IOref.atomicModifyIORef'
tarballHashIORef
(\m -> (Map.insert key hash m, ()))

-- | Transforms a 'GenericPackageDescription' from Cabal into an 'ImportOutput'
-- that can later be inserted into the database. This function produces stable, deterministic ids,
-- so it should be possible to extract and insert a single package many times in a row.
extractPackageDataFromCabal
:: (IOE :> es, Time :> es, Log :> es)
=> UserId
=> IORef (Map (Namespace, PackageName) Text)
-> UserId
-> (Text, Set PackageName)
-> UTCTime
-> GenericPackageDescription
-> Eff es ImportOutput
extractPackageDataFromCabal userId (repositoryName, repositoryPackages) uploadTime genericDesc = do
extractPackageDataFromCabal tarballHashIORef userId (repositoryName, repositoryPackages) uploadTime genericDesc = do
let packageDesc = genericDesc.packageDescription
let flags = Vector.fromList genericDesc.genPackageFlags
let packageName = force $ packageDesc ^. #package % #pkgName % to unPackageName % to pack % to PackageName
Expand All @@ -282,9 +353,16 @@ extractPackageDataFromCabal userId (repositoryName, repositoryPackages) uploadTi
let releaseId = deterministicReleaseId packageId packageVersion
timestamp <- Time.currentTime
let sourceRepos = getRepoURL packageName packageDesc.sourceRepos
let rawCategoryField = packageDesc ^. #category % to Cabal.fromShortText % to T.pack
let categoryList = fmap (Tuning.UserPackageCategory . T.stripStart . T.stripEnd) (T.splitOn "," rawCategoryField)
let rawCategoryField = packageDesc ^. #category % to Cabal.fromShortText % to Text.pack
let categoryList = fmap (Tuning.UserPackageCategory . Text.stripStart . Text.stripEnd) (Text.splitOn "," rawCategoryField)
categories <- liftIO $ Tuning.normalisedCategories <$> Tuning.normalise categoryList
(mTarballHash :: Maybe Text) <- liftIO $ IORef.atomicModifyIORef' tarballHashIORef $ \m ->
let result = Map.lookup (namespace, packageName) m
in case result of
Nothing -> (m, Nothing)
Just hash ->
let newMap = Map.delete (namespace, packageName) m
in (newMap, Just hash)
let package =
Package
{ packageId
Expand All @@ -302,7 +380,7 @@ extractPackageDataFromCabal userId (repositoryName, repositoryPackages) uploadTi
{ releaseId
, packageId
, version = packageVersion
, archiveChecksum = mempty
, archiveChecksum = mTarballHash
, uploadedAt = Just uploadTime
, createdAt = timestamp
, updatedAt = timestamp
Expand Down Expand Up @@ -359,7 +437,7 @@ extractPackageDataFromCabal userId (repositoryName, repositoryPackages) uploadTi
case NE.nonEmpty components' of
Nothing -> do
Log.logAttention "Empty dependencies" $ object ["package" .= package]
extractPackageDataFromCabal userId (repositoryName, repositoryPackages) uploadTime genericDesc
extractPackageDataFromCabal tarballHashIORef userId (repositoryName, repositoryPackages) uploadTime genericDesc
Just components -> pure ImportOutput{..}

extractLibrary
Expand All @@ -379,7 +457,7 @@ extractLibrary package =

getLibName :: PackageName -> LibraryName -> Text
getLibName pname LMainLibName = display pname
getLibName _ (LSubLibName lname) = T.pack $ unUnqualComponentName lname
getLibName _ (LSubLibName lname) = Text.pack $ unUnqualComponentName lname

extractForeignLib
:: Package
Expand All @@ -392,7 +470,7 @@ extractForeignLib
extractForeignLib =
genericComponentExtractor
Component.ForeignLib
(^. #foreignLibName % to unUnqualComponentName % to T.pack)
(^. #foreignLibName % to unUnqualComponentName % to Text.pack)
(^. #foreignLibBuildInfo % #targetBuildDepends)

extractExecutable
Expand All @@ -406,7 +484,7 @@ extractExecutable
extractExecutable =
genericComponentExtractor
Component.Executable
(^. #exeName % to unUnqualComponentName % to T.pack)
(^. #exeName % to unUnqualComponentName % to Text.pack)
(^. #buildInfo % #targetBuildDepends)

extractTestSuite
Expand All @@ -420,7 +498,7 @@ extractTestSuite
extractTestSuite =
genericComponentExtractor
Component.TestSuite
(^. #testName % to unUnqualComponentName % to T.pack)
(^. #testName % to unUnqualComponentName % to Text.pack)
(^. #testBuildInfo % #targetBuildDepends)

extractBenchmark
Expand All @@ -434,7 +512,7 @@ extractBenchmark
extractBenchmark =
genericComponentExtractor
Component.Benchmark
(^. #benchmarkName % to unUnqualComponentName % to T.pack)
(^. #benchmarkName % to unUnqualComponentName % to Text.pack)
(^. #benchmarkBuildInfo % #targetBuildDepends)

-- | Traverses the provided 'CondTree' and applies the given 'ComponentExtractor'
Expand Down
Loading

0 comments on commit 5eb0c64

Please sign in to comment.