From b7bfa48c98f4610ddcaa679122c57f89329c0af3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9ophile=20Choutri?= Date: Tue, 18 Jun 2024 00:12:11 +0200 Subject: [PATCH] [FLORA-414] Store archive hashes --- changelog.d/560 | 4 + ...7215020_make_archive_checksum_nullable.sql | 2 + src/core/Flora/Import/Package.hs | 178 +++++++++++++----- src/core/Flora/Import/Package/Bulk.hs | 54 ++++-- src/core/Flora/Import/Types.hs | 41 +++- src/core/Flora/Model/Package/Query.hs | 20 +- src/core/Flora/Model/Release/Types.hs | 2 +- src/core/Flora/Model/Release/Update.hs | 10 + test/Flora/TestUtils.hs | 4 +- 9 files changed, 230 insertions(+), 85 deletions(-) create mode 100644 changelog.d/560 create mode 100644 migrations/20240617215020_make_archive_checksum_nullable.sql diff --git a/changelog.d/560 b/changelog.d/560 new file mode 100644 index 00000000..87d559db --- /dev/null +++ b/changelog.d/560 @@ -0,0 +1,4 @@ +synopsis: Store archive hashes +prs: #560 +significant: significant + diff --git a/migrations/20240617215020_make_archive_checksum_nullable.sql b/migrations/20240617215020_make_archive_checksum_nullable.sql new file mode 100644 index 00000000..42f33694 --- /dev/null +++ b/migrations/20240617215020_make_archive_checksum_nullable.sql @@ -0,0 +1,2 @@ +alter table releases + alter column archive_checksum drop not null; diff --git a/src/core/Flora/Import/Package.hs b/src/core/Flora/Import/Package.hs index 00f14aae..5be11bdb 100644 --- a/src/core/Flora/Import/Package.hs +++ b/src/core/Flora/Import/Package.hs @@ -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 @@ -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 @@ -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 @@ -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 = "/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) @@ -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 @@ -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 " @@ -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 @@ -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 @@ -302,7 +380,7 @@ extractPackageDataFromCabal userId (repositoryName, repositoryPackages) uploadTi { releaseId , packageId , version = packageVersion - , archiveChecksum = mempty + , archiveChecksum = mTarballHash , uploadedAt = Just uploadTime , createdAt = timestamp , updatedAt = timestamp @@ -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 @@ -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 @@ -392,7 +470,7 @@ extractForeignLib extractForeignLib = genericComponentExtractor Component.ForeignLib - (^. #foreignLibName % to unUnqualComponentName % to T.pack) + (^. #foreignLibName % to unUnqualComponentName % to Text.pack) (^. #foreignLibBuildInfo % #targetBuildDepends) extractExecutable @@ -406,7 +484,7 @@ extractExecutable extractExecutable = genericComponentExtractor Component.Executable - (^. #exeName % to unUnqualComponentName % to T.pack) + (^. #exeName % to unUnqualComponentName % to Text.pack) (^. #buildInfo % #targetBuildDepends) extractTestSuite @@ -420,7 +498,7 @@ extractTestSuite extractTestSuite = genericComponentExtractor Component.TestSuite - (^. #testName % to unUnqualComponentName % to T.pack) + (^. #testName % to unUnqualComponentName % to Text.pack) (^. #testBuildInfo % #targetBuildDepends) extractBenchmark @@ -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' diff --git a/src/core/Flora/Import/Package/Bulk.hs b/src/core/Flora/Import/Package/Bulk.hs index ce3ea363..2f41afb3 100644 --- a/src/core/Flora/Import/Package/Bulk.hs +++ b/src/core/Flora/Import/Package/Bulk.hs @@ -28,24 +28,33 @@ import Effectful import Effectful.FileSystem (FileSystem) import Effectful.FileSystem qualified as FileSystem import Effectful.FileSystem.IO.ByteString qualified as FileSystem +import Effectful.Log (Log) import Effectful.Log qualified as Log import Effectful.Poolboy import Effectful.PostgreSQL.Transact.Effect (DB) import Effectful.Time (Time) +import GHC.Conc (numCapabilities) import Streamly.Data.Fold qualified as SFold import Streamly.Data.Stream (Stream) +import Streamly.Data.Stream.Prelude (maxThreads, ordered) import Streamly.Data.Stream.Prelude qualified as Streamly import System.Directory import System.Directory qualified as System import System.FilePath import UnliftIO.Exception (finally) -import Effectful.Log (Log) +import Data.IORef (IORef) +import Data.IORef qualified as IORef +import Data.Map (Map) +import Data.Map.Strict qualified as Map import Flora.Import.Package ( extractPackageDataFromCabal , loadContent + , loadJSONContent + , persistHashes , persistImportOutput ) +import Flora.Import.Types (ImportFileType (..)) import Flora.Model.Package import Flora.Model.Package.Update qualified as Update import Flora.Model.PackageIndex.Query qualified as Query @@ -54,8 +63,6 @@ import Flora.Model.PackageIndex.Update qualified as Update import Flora.Model.Release.Query qualified as Query import Flora.Model.Release.Update qualified as Update import Flora.Model.User -import GHC.Conc (numCapabilities) -import Streamly.Data.Stream.Prelude (maxThreads, ordered) -- | Same as 'importAllFilesInDirectory' but accepts a relative path to the current working directory importAllFilesInRelativeDirectory @@ -97,16 +104,18 @@ importFromIndex user (repositoryName, repositoryURL) index = do where buildContentStream :: UTCTime - -> Stream (Eff es) (FilePath, UTCTime, StrictByteString) + -> Stream (Eff es) (ImportFileType, UTCTime, StrictByteString) -> Tar.GenEntry Tar.TarPath linkTarget - -> Stream (Eff es) (FilePath, UTCTime, StrictByteString) + -> Stream (Eff es) (ImportFileType, UTCTime, StrictByteString) buildContentStream time acc entry = let entryPath = Tar.entryPath entry entryTime = posixSecondsToUTCTime . fromIntegral $ Tar.entryTime entry in Tar.entryContent entry & \case Tar.NormalFile bs _ | ".cabal" `isSuffixOf` entryPath && entryTime > time -> - (entryPath, entryTime, BL.toStrict bs) `Streamly.cons` acc + (CabalFile entryPath, entryTime, BL.toStrict bs) `Streamly.cons` acc + | ".json" `isSuffixOf` entryPath && entryTime > time -> + (JSONFile entryPath, entryTime, BL.toStrict bs) `Streamly.cons` acc _ -> acc -- | Finds all cabal files in the specified directory, and inserts them into the database after extracting the relevant data @@ -127,14 +136,15 @@ importFromStream . (Time :> es, Log :> es, Poolboy :> es, DB :> es, IOE :> es) => UserId -> (Text, Text, Set PackageName) - -> Stream (Eff es) (String, UTCTime, StrictByteString) + -> Stream (Eff es) (ImportFileType, UTCTime, StrictByteString) -> Eff es () importFromStream user (repositoryName, _repositoryURL, repositoryPackages) stream = do + tarballHashIORef <- liftIO $ IORef.newIORef Map.empty let cfg = maxThreads numCapabilities . ordered True processedPackageCount <- finally ( Streamly.fold displayCount $ - Streamly.parMapM cfg processFile stream + Streamly.parMapM cfg (processFile tarballHashIORef) stream ) -- We want to refresh db and update latest timestamp even if we fell -- over at some point @@ -155,12 +165,22 @@ importFromStream user (repositoryName, _repositoryURL, repositoryPackages) strea when (currentCount `mod` 400 == 0) $ displayStats currentCount pure currentCount - processFile :: (String, UTCTime, StrictByteString) -> Eff es () - processFile (path, timestamp, content) = - loadContent path content - >>= ( extractPackageDataFromCabal user (repositoryName, repositoryPackages) timestamp - >=> \importedPackage -> persistImportOutput importedPackage - ) + processFile + :: IORef (Map (Namespace, PackageName) Text) + -> (ImportFileType, UTCTime, StrictByteString) + -> Eff es () + processFile tarballHashIORef importSubject = + case importSubject of + (CabalFile path, timestamp, content) -> + loadContent path content + >>= ( extractPackageDataFromCabal tarballHashIORef user (repositoryName, repositoryPackages) timestamp + >=> \importedPackage -> persistImportOutput importedPackage + ) + (JSONFile path, _, content) -> + do + loadJSONContent path content (repositoryName, repositoryPackages) + >>= persistHashes tarballHashIORef + displayStats :: Int -> Eff es () displayStats currentCount = liftIO . putStrLn $ "✅ Processed " <> show currentCount <> " new cabal files" @@ -169,10 +189,10 @@ findAllCabalFilesInDirectory :: forall es . FileSystem :> es => FilePath - -> Stream (Eff es) (String, UTCTime, StrictByteString) + -> Stream (Eff es) (ImportFileType, UTCTime, StrictByteString) findAllCabalFilesInDirectory workdir = Streamly.concatMapM traversePath $ Streamly.fromList [workdir] where - traversePath :: FilePath -> Eff es (Stream (Eff es) (FilePath, UTCTime, StrictByteString)) + traversePath :: FilePath -> Eff es (Stream (Eff es) (ImportFileType, UTCTime, StrictByteString)) traversePath p = do isDir <- FileSystem.doesDirectoryExist p case isDir of @@ -182,7 +202,7 @@ findAllCabalFilesInDirectory workdir = Streamly.concatMapM traversePath $ Stream False | ".cabal" `isSuffixOf` p -> do content <- FileSystem.readFile p timestamp <- FileSystem.getModificationTime p - pure $ Streamly.fromPure (p, timestamp, content) + pure $ Streamly.fromPure (CabalFile p, timestamp, content) _ -> pure Streamly.nil buildPackageListFromArchive :: Entries e -> Either e (Set PackageName) diff --git a/src/core/Flora/Import/Types.hs b/src/core/Flora/Import/Types.hs index 5316020a..9b7ae0a7 100644 --- a/src/core/Flora/Import/Types.hs +++ b/src/core/Flora/Import/Types.hs @@ -1,7 +1,18 @@ -module Flora.Import.Types where +module Flora.Import.Types + ( ImportError (..) + , Target (..) + , Hashes (..) + , ImportFileType (..) + , ReleaseJSONFile (..) + , Signed (..) + ) where import Control.Exception +import Data.Aeson +import Data.Aeson.KeyMap import Data.Text (Text) +import GHC.Generics + import Flora.Model.Package data ImportError @@ -12,3 +23,31 @@ data ImportError | CabalFileCouldNotBeParsed FilePath deriving stock (Eq, Show) deriving anyclass (Exception) + +data ReleaseJSONFile = ReleaseJSONFile + { signed :: Signed + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON, ToJSON) + +data Signed = Signed + { targets :: KeyMap Target + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON, ToJSON) + +data Target = Target + { hashes :: Hashes + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON, ToJSON) + +data Hashes = Hashes + { sha256 :: Text + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON, ToJSON) + +data ImportFileType + = CabalFile FilePath + | JSONFile FilePath diff --git a/src/core/Flora/Model/Package/Query.hs b/src/core/Flora/Model/Package/Query.hs index f55f987e..a8f4b7a2 100644 --- a/src/core/Flora/Model/Package/Query.hs +++ b/src/core/Flora/Model/Package/Query.hs @@ -86,21 +86,13 @@ getAllPackages = do getPackagesByNamespace :: DB :> es => Namespace -> Eff es (Vector Package) getPackagesByNamespace namespace = dbtToEff $ selectManyByField @Package [field| namespace |] (Only namespace) -getPackageByNamespaceAndName :: (DB :> es, Log :> es, Time :> es) => Namespace -> PackageName -> Eff es (Maybe Package) +getPackageByNamespaceAndName :: DB :> es => Namespace -> PackageName -> Eff es (Maybe Package) getPackageByNamespaceAndName namespace name = do - (result, duration) <- - timeAction $ - dbtToEff $ - queryOne - Select - (_selectWhere @Package [[field| namespace |], [field| name |]]) - (namespace, name) - Log.logInfo "Get package by namespace and name" $ - object - [ "duration" .= duration - , "package" .= result - ] - pure result + dbtToEff $ + queryOne + Select + (_selectWhere @Package [[field| namespace |], [field| name |]]) + (namespace, name) getNonDeprecatedPackages :: DB :> es => Eff es (Vector Package) getNonDeprecatedPackages = dbtToEff $ selectWhereNull @Package [[field| deprecation_info |]] diff --git a/src/core/Flora/Model/Release/Types.hs b/src/core/Flora/Model/Release/Types.hs index 67aa55b5..a95afb20 100644 --- a/src/core/Flora/Model/Release/Types.hs +++ b/src/core/Flora/Model/Release/Types.hs @@ -83,7 +83,7 @@ data Release = Release { releaseId :: ReleaseId , packageId :: PackageId , version :: Version - , archiveChecksum :: Text + , archiveChecksum :: Maybe Text , uploadedAt :: Maybe UTCTime , createdAt :: UTCTime , updatedAt :: UTCTime diff --git a/src/core/Flora/Model/Release/Update.hs b/src/core/Flora/Model/Release/Update.hs index 7358f952..7bb7eddc 100644 --- a/src/core/Flora/Model/Release/Update.hs +++ b/src/core/Flora/Model/Release/Update.hs @@ -17,6 +17,7 @@ import Crypto.Hash.SHA256 qualified as SHA import Data.ByteString (toStrict) import Data.ByteString.Lazy (LazyByteString) import Data.Function ((&)) +import Data.Text (Text) import Data.Time (UTCTime) import Data.Vector (Vector) import Data.Vector qualified as Vector @@ -108,3 +109,12 @@ setReleasesDeprecationMarker releaseVersions = FROM (VALUES (?,?)) as upd(x,y) WHERE r0.release_id = (upd.y :: uuid) |] + +setArchiveChecksum :: DB :> es => ReleaseId -> Text -> Eff es () +setArchiveChecksum releaseId sha256Hash = + dbtToEff $ + void $ + updateFieldsBy @Release + [[field| archive_checksum |]] + ([field| release_id |], releaseId) + (Only sha256Hash) diff --git a/test/Flora/TestUtils.hs b/test/Flora/TestUtils.hs index 0968e66d..78cbeeef 100644 --- a/test/Flora/TestUtils.hs +++ b/test/Flora/TestUtils.hs @@ -473,7 +473,7 @@ data ReleaseTemplate m = ReleaseTemplate { releaseId :: m ReleaseId , packageId :: m PackageId , version :: m Version - , archiveChecksum :: m Text + , archiveChecksum :: m (Maybe Text) , uploadedAt :: m (Maybe UTCTime) , createdAt :: m UTCTime , updatedAt :: m UTCTime @@ -508,7 +508,7 @@ randomReleaseTemplate = , version = do result <- H.sample $ H.nonEmpty (Range.singleton 4) (H.int (Range.constant 0 10)) pure $ Version.mkVersion $ NE.toList result - , archiveChecksum = H.sample $ H.text (Range.singleton 30) H.ascii + , archiveChecksum = pure Nothing , uploadedAt = Just <$> H.sample genUTCTime , updatedAt = H.sample genUTCTime , createdAt = H.sample genUTCTime