haskell/stackage-server
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage-server.git synced 2026-01-19 23:51:54 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

Store fallback cabal files into pantry. And few follow up improvements:

Browse Source 
* Fix atomic durable writing, since issue in RIO was fixed

* Log information about falling back onto the core-cabal-files repo

* Convert conduit pipe to Maybe fishes.

* Make sure module names, package name and version are added for fallback
  cabal files
This commit is contained in:
Alexey Kuleshevich 2020-02-12 02:21:12 +03:00
parent 8e247dde03
commit bdcdd1887a
No known key found for this signature in database
GPG Key ID: E59B216127119E3E
9 changed files with 160 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
src/Handler/Package.hs
View File

@ -73,9 +73,7 @@ checkSpam pname inner = do
$(widgetFile "spam-package") $(widgetFile "spam-package")
else inner else inner
packagePage :: Maybe SnapshotPackageInfo packagePage :: Maybe SnapshotPackageInfo -> PackageNameP -> Handler Html
-> PackageNameP
-> Handler Html
packagePage mspi pname = packagePage mspi pname =
track "Handler.Package.packagePage" $ track "Handler.Package.packagePage" $
checkSpam pname $ checkSpam pname $
@ -86,8 +84,6 @@ packagePage mspi pname =
Just spi -> handlePackage $ Right spi Just spi -> handlePackage $ Right spi
handlePackage :: Either HackageCabalInfo SnapshotPackageInfo -> Handler Html handlePackage :: Either HackageCabalInfo SnapshotPackageInfo -> Handler Html
handlePackage epi = do handlePackage epi = do
(isDeprecated, inFavourOf) <- getDeprecated pname (isDeprecated, inFavourOf) <- getDeprecated pname

83
src/Stackage/Database/Cron.hs
View File

@ -46,6 +46,7 @@ import Pantry.Internal.Stackage (HackageTarballResult(..),
import Path (parseAbsDir, toFilePath) import Path (parseAbsDir, toFilePath)
import RIO import RIO
import RIO.Directory import RIO.Directory
import RIO.File
import RIO.FilePath import RIO.FilePath
import RIO.List as L import RIO.List as L
import qualified RIO.Map as Map import qualified RIO.Map as Map
@ -115,7 +116,6 @@ newHoogleLocker env man = mkSingleRun hoogleLocker
hoogleLocker name = hoogleLocker name =
runRIO env $ do runRIO env $ do
let fp = T.unpack $ hoogleKey name let fp = T.unpack $ hoogleKey name
fptmp = fp <.> "tmp"
exists <- doesFileExist fp exists <- doesFileExist fp
if exists if exists
then return $ Just fp then return $ Just fp
@ -126,24 +126,17 @@ newHoogleLocker env man = mkSingleRun hoogleLocker
case responseStatus res of case responseStatus res of
status status
| status == status200 -> do | status == status200 -> do
createDirectoryIfMissing True $ takeDirectory fptmp createDirectoryIfMissing True $ takeDirectory fp
-- TODO: https://github.com/commercialhaskell/rio/issues/160 withBinaryFileDurableAtomic fp WriteMode $ \h ->
-- withBinaryFileDurableAtomic fp WriteMode $ \h -> runConduitRes $
-- runConduitRes $
-- bodyReaderSource (responseBody res) .| ungzip .|
-- sinkHandle h
runConduitRes $
bodyReaderSource (responseBody res) .| ungzip .| bodyReaderSource (responseBody res) .| ungzip .|
sinkFile fptmp sinkHandle h
renamePath fptmp fp
return $ Just fp return $ Just fp
| status == status404 -> do | status == status404 -> do
logDebug $ "NotFound: " <> display (hoogleUrl name) logDebug $ "NotFound: " <> display (hoogleUrl name)
return Nothing return Nothing
| otherwise -> do | otherwise -> do
body <- liftIO $ brConsume $ responseBody res body <- liftIO $ brConsume $ responseBody res
-- TODO: ideally only consume the body when log level set to
-- LevelDebug, will require a way to get LogLevel from LogFunc
mapM_ (logDebug . displayBytesUtf8) body mapM_ (logDebug . displayBytesUtf8) body
return Nothing return Nothing
@ -251,7 +244,9 @@ makeCorePackageGetters = do
"Error parsing 'global-hints.yaml' file: " <> fromString (displayException exc) "Error parsing 'global-hints.yaml' file: " <> fromString (displayException exc)
return mempty return mempty
getCoreCabalFiles :: FilePath -> RIO StackageCron (Map PackageIdentifierP GenericPackageDescription) getCoreCabalFiles ::
FilePath
-> RIO StackageCron (Map PackageIdentifierP (GenericPackageDescription, CabalFileIds))
getCoreCabalFiles rootDir = do getCoreCabalFiles rootDir = do
coreCabalFilesDir <- getCoreCabalFilesDir rootDir coreCabalFilesDir <- getCoreCabalFilesDir rootDir
cabalFileNames <- getDirectoryContents coreCabalFilesDir cabalFileNames <- getDirectoryContents coreCabalFilesDir
@ -262,11 +257,10 @@ getCoreCabalFiles rootDir = do
Nothing -> do Nothing -> do
logError $ "Invalid package identifier: " <> fromString cabalFileName logError $ "Invalid package identifier: " <> fromString cabalFileName
pure Nothing pure Nothing
Just pid@(PackageIdentifierP pname _) -> do Just pid -> do
mgpd <- cabalBlob <- readFileBinary (coreCabalFilesDir </> cabalFileName)
readFileBinary (coreCabalFilesDir </> cabalFileName) >>= mCabalInfo <- run $ addCabalFile pid cabalBlob
parseCabalBlobMaybe pname pure ((,) pid <$> mCabalInfo)
pure ((,) pid <$> mgpd)
pure $ Map.fromList $ catMaybes cabalFiles pure $ Map.fromList $ catMaybes cabalFiles
-- | Core package info rarely changes between the snapshots, therefore it would be wasteful to -- | Core package info rarely changes between the snapshots, therefore it would be wasteful to
@ -275,7 +269,7 @@ getCoreCabalFiles rootDir = do
-- package on subsequent invocations. -- package on subsequent invocations.
makeCorePackageGetter :: makeCorePackageGetter ::
CompilerP CompilerP
-> Map PackageIdentifierP GenericPackageDescription -> Map PackageIdentifierP (GenericPackageDescription, CabalFileIds)
-> PackageNameP -> PackageNameP
-> VersionP -> VersionP
-> RIO StackageCron (Maybe CorePackageGetter) -> RIO StackageCron (Maybe CorePackageGetter)
@ -284,9 +278,17 @@ makeCorePackageGetter _compiler fallbackCabalFileMap pname ver =
Nothing -> do Nothing -> do
logWarn $ logWarn $
"Core package from global-hints: '" <> display pid <> "' was not found in pantry." "Core package from global-hints: '" <> display pid <> "' was not found in pantry."
pure (pure . (,,,) Nothing Nothing pid <$> Map.lookup pid fallbackCabalFileMap) forM (Map.lookup pid fallbackCabalFileMap) $ \(gpd, cabalFileIds) -> do
logInfo $
"Falling back on '" <> display pid <>
".cabal' file from the commercialhaskell/core-cabal-files repo"
pure $ pure (Left cabalFileIds, Nothing, pid, gpd)
Just (hackageCabalId, blobId, _) -> do Just (hackageCabalId, blobId, _) -> do
pkgInfoRef <- newIORef Nothing -- use for caching of pkgInfo pkgInfoRef <- newIORef Nothing -- use for caching of pkgInfo
let getCabalFileIdsTree gpd =
\case
Just tree -> pure $ Right tree
Nothing -> Left <$> getCabalFileIds blobId gpd
let getMemoPackageInfo = let getMemoPackageInfo =
readIORef pkgInfoRef >>= \case readIORef pkgInfoRef >>= \case
Just pkgInfo -> return pkgInfo Just pkgInfo -> return pkgInfo
@ -296,17 +298,21 @@ makeCorePackageGetter _compiler fallbackCabalFileMap pname ver =
htr <- getHackageTarball pir Nothing htr <- getHackageTarball pir Nothing
case htrFreshPackageInfo htr of case htrFreshPackageInfo htr of
Just (gpd, treeId) -> do Just (gpd, treeId) -> do
mTree <- run $ getEntity treeId eTree <-
let pkgInfo = (mTree, Just hackageCabalId, pid, gpd) run $ do
mTree <- getEntity treeId
getCabalFileIdsTree gpd mTree
let pkgInfo = (eTree, Just hackageCabalId, pid, gpd)
gpd `deepseq` writeIORef pkgInfoRef $ Just pkgInfo gpd `deepseq` writeIORef pkgInfoRef $ Just pkgInfo
pure pkgInfo pure pkgInfo
Nothing -> do Nothing -> do
(cabalBlob, mTree) <- (gpd, eCabalTree) <-
run run $ do
((,) <$> loadBlobById blobId <*> cabalBlob <- loadBlobById blobId
getTreeForKey (packageTreeKey (htrPackage htr))) let gpd = parseCabalBlob cabalBlob
let gpd = parseCabalBlob cabalBlob mTree <- getTreeForKey (packageTreeKey (htrPackage htr))
pkgInfo = (mTree, Just hackageCabalId, pid, gpd) (,) gpd <$> getCabalFileIdsTree gpd mTree
let pkgInfo = (eCabalTree, Just hackageCabalId, pid, gpd)
gpd `deepseq` writeIORef pkgInfoRef $ Just pkgInfo gpd `deepseq` writeIORef pkgInfoRef $ Just pkgInfo
pure pkgInfo pure pkgInfo
pure $ Just getMemoPackageInfo pure $ Just getMemoPackageInfo
@ -348,11 +354,12 @@ addPantryPackage sid compiler isHidden flags (PantryPackage pc treeKey) = do
, tid /= treeId -> do , tid /= treeId -> do
lift $ logError $ "Pantry Tree Key mismatch for: " <> display pc lift $ logError $ "Pantry Tree Key mismatch for: " <> display pc
pure False pure False
mTree@(Just (Entity _ Tree {treeCabal})) Just tree@(Entity _ Tree {treeCabal})
| Just treeCabal' <- treeCabal -> do | Just treeCabal' <- treeCabal -> do
gpd <- getCachedGPD treeCabal' mgpd gpd <- getCachedGPD treeCabal' mgpd
let mhcid = Just hcid let mhcid = Just hcid
addSnapshotPackage sid compiler Hackage mTree mhcid isHidden flags pid gpd eTree = Right tree
addSnapshotPackage sid compiler Hackage eTree mhcid isHidden flags pid gpd
pure True pure True
_ -> do _ -> do
lift $ logError $ "Pantry is missing the source tree for " <> display pc lift $ logError $ "Pantry is missing the source tree for " <> display pc
@ -386,9 +393,7 @@ checkForDocs snapshotId snapName = do
runConduit $ runConduit $
AWS.paginate (req bucketName) .| concatMapC (^. lovrsContents) .| AWS.paginate (req bucketName) .| concatMapC (^. lovrsContents) .|
mapC (\obj -> toText (obj ^. oKey)) .| mapC (\obj -> toText (obj ^. oKey)) .|
concatMapC (T.stripSuffix ".html") .| concatMapC (T.stripSuffix ".html" >=> T.stripPrefix prefix >=> pathToPackageModule) .|
concatMapC (T.stripPrefix prefix) .|
concatMapC pathToPackageModule .|
sinkList sinkList
-- it is faster to download all modules in this snapshot, than process them with a conduit all -- it is faster to download all modules in this snapshot, than process them with a conduit all
-- the way to the database. -- the way to the database.
@ -515,7 +520,7 @@ decideOnSnapshotUpdate SnapshotFileInfo {sfiSnapName, sfiUpdatedOn, sfiSnapshotF
_ -> return Nothing _ -> return Nothing
type CorePackageGetter type CorePackageGetter
= RIO StackageCron ( Maybe (Entity Tree) = RIO StackageCron ( Either CabalFileIds (Entity Tree)
, Maybe HackageCabalId , Maybe HackageCabalId
, PackageIdentifierP , PackageIdentifierP
, GenericPackageDescription) , GenericPackageDescription)
@ -617,8 +622,8 @@ updateSnapshot corePackageGetters snapshotId snapName updatedOn SnapshotFile {..
] ]
Just compilerCorePackages -> Just compilerCorePackages ->
forM_ compilerCorePackages $ \getCorePackageInfo -> do forM_ compilerCorePackages $ \getCorePackageInfo -> do
(mTree, mhcid, pid, gpd) <- getCorePackageInfo (eTree, mhcid, pid, gpd) <- getCorePackageInfo
run $ addSnapshotPackage snapshotId sfCompiler Core mTree mhcid False mempty pid gpd run $ addSnapshotPackage snapshotId sfCompiler Core eTree mhcid False mempty pid gpd
return $ do return $ do
checkForDocsSucceeded <- checkForDocsSucceeded <-
tryAny (checkForDocs snapshotId snapName) >>= \case tryAny (checkForDocs snapshotId snapName) >>= \case
@ -726,12 +731,8 @@ createHoogleDB snapshotId snapName =
withResponseUnliftIO req {decompress = const True} man $ \res -> do withResponseUnliftIO req {decompress = const True} man $ \res -> do
throwErrorStatusCodes req res throwErrorStatusCodes req res
createDirectoryIfMissing True $ takeDirectory tarFP createDirectoryIfMissing True $ takeDirectory tarFP
--withBinaryFileDurableAtomic tarFP WriteMode $ \tarHandle -> withBinaryFileDurableAtomic tarFP WriteMode $ \tarHandle ->
--FIXME: https://github.com/commercialhaskell/rio/issues/160
let tmpTarFP = tarFP <.> "tmp"
withBinaryFile tmpTarFP WriteMode $ \tarHandle ->
runConduitRes $ bodyReaderSource (responseBody res) .| sinkHandle tarHandle runConduitRes $ bodyReaderSource (responseBody res) .| sinkHandle tarHandle
renameFile tmpTarFP tarFP
void $ tryIO $ removeDirectoryRecursive bindir void $ tryIO $ removeDirectoryRecursive bindir
void $ tryIO $ removeFile outname void $ tryIO $ removeFile outname
createDirectoryIfMissing True bindir createDirectoryIfMissing True bindir

36
src/Stackage/Database/PackageInfo.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ViewPatterns #-}
module Stackage.Database.PackageInfo module Stackage.Database.PackageInfo
( PackageInfo(..) ( PackageInfo(..)
, Identifier(..) , Identifier(..)
@ -14,10 +14,11 @@ module Stackage.Database.PackageInfo
) where ) where
import CMarkGFM import CMarkGFM
import Data.Coerce
import Data.Char (isSpace) import Data.Char (isSpace)
import Data.Coerce
import Data.Map.Merge.Strict as Map import Data.Map.Merge.Strict as Map
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Distribution.Compiler (CompilerFlavor(GHC)) import Distribution.Compiler (CompilerFlavor(GHC))
import Distribution.Package (Dependency(..)) import Distribution.Package (Dependency(..))
import Distribution.PackageDescription (CondTree(..), Condition(..), import Distribution.PackageDescription (CondTree(..), Condition(..),
@ -26,28 +27,29 @@ import Distribution.PackageDescription (CondTree(..), Condition(..),
GenericPackageDescription, author, GenericPackageDescription, author,
condExecutables, condLibrary, condExecutables, condLibrary,
description, genPackageFlags, homepage, description, genPackageFlags, homepage,
license, maintainer, license, maintainer, packageDescription,
packageDescription, synopsis) synopsis)
import Distribution.PackageDescription.Parsec (parseGenericPackageDescription, import Distribution.PackageDescription.Parsec (parseGenericPackageDescription,
runParseResult) runParseResult)
import Distribution.Pretty (prettyShow) import Distribution.Pretty (prettyShow)
import Distribution.System (Arch(X86_64), OS(Linux)) import Distribution.System (Arch(X86_64), OS(Linux))
import Distribution.Types.CondTree (CondBranch(..)) import Distribution.Types.CondTree (CondBranch(..))
import Distribution.Types.Library (exposedModules) import Distribution.Types.Library (exposedModules)
import Distribution.Types.PackageDescription (PackageDescription(package))
import Distribution.Types.VersionRange (VersionRange, intersectVersionRanges, import Distribution.Types.VersionRange (VersionRange, intersectVersionRanges,
normaliseVersionRange, withinRange) normaliseVersionRange, withinRange)
import Distribution.Version (simplifyVersionRange) import Distribution.Version (simplifyVersionRange)
import qualified Data.Text.Encoding as T
import RIO import RIO
import qualified RIO.Map as Map import qualified RIO.Map as Map
import qualified RIO.Map.Unchecked as Map (mapKeysMonotonic) import qualified RIO.Map.Unchecked as Map (mapKeysMonotonic)
import Stackage.Database.Haddock (renderHaddock) import Stackage.Database.Haddock (renderHaddock)
import Stackage.Database.Types (Changelog(..), Readme(..)) import Stackage.Database.Types (Changelog(..), Readme(..))
import Text.Blaze.Html (Html, preEscapedToHtml, toHtml) import Text.Blaze.Html (Html, preEscapedToHtml, toHtml)
import Types (CompilerP(..), FlagNameP(..), ModuleNameP(..), PackageNameP(..),
SafeFilePath, VersionP(..), VersionRangeP(..), unSafeFilePath)
import Yesod.Form.Fields (Textarea(..))
import Text.Email.Validate import Text.Email.Validate
import Types (CompilerP(..), FlagNameP(..), ModuleNameP(..), PackageIdentifierP,
PackageNameP(..), SafeFilePath, VersionP(..), VersionRangeP(..),
unSafeFilePath, dtDisplay)
import Yesod.Form.Fields (Textarea(..))
data PackageInfo = PackageInfo data PackageInfo = PackageInfo
@ -79,7 +81,7 @@ toPackageInfo gpd mreadme mchangelog =
, piHomepage = , piHomepage =
case T.strip $ T.pack $ homepage pd of case T.strip $ T.pack $ homepage pd of
"" -> Nothing "" -> Nothing
x -> Just x x -> Just x
, piLicenseName = T.pack $ prettyShow $ license pd , piLicenseName = T.pack $ prettyShow $ license pd
} }
where where
@ -125,17 +127,23 @@ parseCabalBlob cabalBlob =
parseCabalBlobMaybe :: parseCabalBlobMaybe ::
(MonadIO m, MonadReader env m, HasLogFunc env) (MonadIO m, MonadReader env m, HasLogFunc env)
=> PackageNameP => PackageIdentifierP
-> ByteString -> ByteString
-> m (Maybe GenericPackageDescription) -> m (Maybe GenericPackageDescription)
parseCabalBlobMaybe packageName cabalBlob = parseCabalBlobMaybe pidp cabalBlob =
case snd $ runParseResult $ parseGenericPackageDescription cabalBlob of case snd $ runParseResult $ parseGenericPackageDescription cabalBlob of
Left err -> Left err ->
Nothing <$ Nothing <$
logError logError
("Problem parsing cabal blob for '" <> display packageName <> "': " <> ("Problem parsing cabal blob for '" <> display pidp <> "': " <> displayShow err)
displayShow err) Right gpd -> do
Right pgd -> pure $ Just pgd let pid = package (packageDescription gpd)
unless (textDisplay (dtDisplay pid :: Utf8Builder) == textDisplay pidp) $
logError $
"Supplied package identifier: '" <> display pidp <>
"' does not match the one in cabal file: '" <>
dtDisplay pid
pure $ Just gpd
getCheckCond :: getCheckCond ::
CompilerP -> Map FlagName Bool -> GenericPackageDescription -> Condition ConfVar -> Bool CompilerP -> Map FlagName Bool -> GenericPackageDescription -> Condition ConfVar -> Bool

111
src/Stackage/Database/Query.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
module Stackage.Database.Query module Stackage.Database.Query
( (
@ -52,13 +53,15 @@ module Stackage.Database.Query
, getTreeForKey , getTreeForKey
, treeCabal , treeCabal
-- ** Stackage server -- ** Stackage server
, CabalFileIds
, addCabalFile
, getCabalFileIds
, addSnapshotPackage , addSnapshotPackage
, getHackageCabalByRev0 , getHackageCabalByRev0
, getHackageCabalByKey , getHackageCabalByKey
, snapshotMarkUpdated , snapshotMarkUpdated
, insertSnapshotName , insertSnapshotName
, markModuleHasDocs , markModuleHasDocs
, insertSnapshotPackageModules
, insertDeps , insertDeps
-- ** For Hoogle db creation -- ** For Hoogle db creation
, lastLtsNightly , lastLtsNightly
@ -71,11 +74,14 @@ import qualified Data.List as L
import Database.Esqueleto import Database.Esqueleto
import Database.Esqueleto.Internal.Language (FromPreprocess) import Database.Esqueleto.Internal.Language (FromPreprocess)
import Database.Esqueleto.Internal.Sql import Database.Esqueleto.Internal.Sql
import Distribution.Types.PackageId (PackageIdentifier(PackageIdentifier))
import Distribution.PackageDescription (packageDescription)
import Distribution.Types.PackageDescription (PackageDescription(package))
import qualified Database.Persist as P import qualified Database.Persist as P
import Pantry.Internal.Stackage (EntityField(..), PackageName, import Pantry.Internal.Stackage (EntityField(..), PackageName,
Version, getBlobKey, getPackageNameById, Version, getBlobKey, getPackageNameById,
getPackageNameId, getTreeForKey, getVersionId, getPackageNameId, getTreeForKey, getVersionId,
loadBlobById, mkSafeFilePath) loadBlobById, storeBlob, mkSafeFilePath)
import RIO hiding (on, (^.)) import RIO hiding (on, (^.))
import qualified RIO.Map as Map import qualified RIO.Map as Map
import qualified RIO.Set as Set import qualified RIO.Set as Set
@ -776,6 +782,75 @@ insertDeps pid snapshotPackageId dependencies =
display dep display dep
return $ Just dep return $ Just dep
data CabalFileIds = CabalFileIds
{ cfiPackageNameId :: !PackageNameId
, cfiVersionId :: !VersionId
, cfiCabalBlobId :: !(Maybe BlobId)
, cfiModuleNameIds :: ![ModuleNameId]
}
getCabalFileIds ::
HasLogFunc env
=> BlobId
-> GenericPackageDescription
-> ReaderT SqlBackend (RIO env) CabalFileIds
getCabalFileIds cabalBlobId gpd = do
let PackageIdentifier name ver = package (packageDescription gpd)
packageNameId <- getPackageNameId name
versionId <- getVersionId ver
moduleNameIds <- mapM insertModuleSafe (extractModuleNames gpd)
pure
CabalFileIds
{ cfiPackageNameId = packageNameId
, cfiVersionId = versionId
, cfiCabalBlobId = Just cabalBlobId
, cfiModuleNameIds = moduleNameIds
}
addCabalFile ::
HasLogFunc env
=> PackageIdentifierP
-> ByteString
-> ReaderT SqlBackend (RIO env) (Maybe (GenericPackageDescription, CabalFileIds))
addCabalFile pid cabalBlob = do
mgpd <- lift $ parseCabalBlobMaybe pid cabalBlob
forM mgpd $ \gpd -> do
(cabalBlobId, _) <- storeBlob cabalBlob
cabalIds <- getCabalFileIds cabalBlobId gpd
pure (gpd, cabalIds)
getPackageIds ::
GenericPackageDescription
-> Either CabalFileIds (Entity Tree)
-> ReaderT SqlBackend (RIO env) (CabalFileIds, Maybe (TreeId, BlobId))
getPackageIds gpd =
\case
Left cabalFileIds -> pure (cabalFileIds, Nothing)
Right (Entity treeId tree)
-- -- TODO: Remove Maybe from cfiCabalBlobId and
-- -- Generate cabal file from package.yaml:
-- case treeCabal tree of
-- Just cabalBlobId -> pure cabalBlobId
-- Nothing -> do
-- let rawMetaData = RawPackageMetadata {
-- rpmName = Just pname
-- , rpmVersion = Just pver
-- , rpmTreeKey = treeKey tree
-- }
-- rpli = ... get
-- generateHPack (RPLIArchive / RPLIRepo ..) treeId treeVersion tree
-- ...
-> do
moduleNameIds <- mapM insertModuleSafe (extractModuleNames gpd)
let cabalFileIds =
CabalFileIds
{ cfiPackageNameId = treeName tree
, cfiVersionId = treeVersion tree
, cfiCabalBlobId = treeCabal tree
, cfiModuleNameIds = moduleNameIds
}
pure (cabalFileIds, Just (treeId, treeKey tree))
-- TODO: Optimize, whenever package is already in one snapshot only create the modules and new -- TODO: Optimize, whenever package is already in one snapshot only create the modules and new
-- SnapshotPackage -- SnapshotPackage
addSnapshotPackage :: addSnapshotPackage ::
@ -783,30 +858,27 @@ addSnapshotPackage ::
=> SnapshotId => SnapshotId
-> CompilerP -> CompilerP
-> Origin -> Origin
-> Maybe (Entity Tree) -> Either CabalFileIds (Entity Tree)
-> Maybe HackageCabalId -> Maybe HackageCabalId
-> Bool -> Bool
-> Map FlagNameP Bool -> Map FlagNameP Bool
-> PackageIdentifierP -> PackageIdentifierP
-> GenericPackageDescription -> GenericPackageDescription
-> ReaderT SqlBackend (RIO env) () -> ReaderT SqlBackend (RIO env) ()
addSnapshotPackage snapshotId compiler origin mTree mHackageCabalId isHidden flags pid gpd = do addSnapshotPackage snapshotId compiler origin eCabalTree mHackageCabalId isHidden flags pid gpd = do
let PackageIdentifierP pname pver = pid (CabalFileIds{..}, mTree) <- getPackageIds gpd eCabalTree
mTreeId = entityKey <$> mTree let mTreeId = fst <$> mTree
packageNameId <-
maybe (getPackageNameId (unPackageNameP pname)) (pure . treeName . entityVal) mTree
versionId <- maybe (getVersionId (unVersionP pver)) (pure . treeVersion . entityVal) mTree
mrevision <- maybe (pure Nothing) getHackageRevision mHackageCabalId mrevision <- maybe (pure Nothing) getHackageRevision mHackageCabalId
mreadme <- fromMaybe (pure Nothing) $ getContentTreeEntryId <$> mTreeId <*> mreadmeQuery mreadme <- fromMaybe (pure Nothing) $ getContentTreeEntryId <$> mTreeId <*> mreadmeQuery
mchangelog <- fromMaybe (pure Nothing) $ getContentTreeEntryId <$> mTreeId <*> mchangelogQuery mchangelog <- fromMaybe (pure Nothing) $ getContentTreeEntryId <$> mTreeId <*> mchangelogQuery
let snapshotPackage = let snapshotPackage =
SnapshotPackage SnapshotPackage
{ snapshotPackageSnapshot = snapshotId { snapshotPackageSnapshot = snapshotId
, snapshotPackagePackageName = packageNameId , snapshotPackagePackageName = cfiPackageNameId
, snapshotPackageVersion = versionId , snapshotPackageVersion = cfiVersionId
, snapshotPackageRevision = mrevision , snapshotPackageRevision = mrevision
, snapshotPackageCabal = treeCabal =<< entityVal <$> mTree , snapshotPackageCabal = cfiCabalBlobId
, snapshotPackageTreeBlob = treeKey . entityVal <$> mTree , snapshotPackageTreeBlob = snd <$> mTree
, snapshotPackageOrigin = origin , snapshotPackageOrigin = origin
, snapshotPackageOriginUrl = "" -- TODO: add , snapshotPackageOriginUrl = "" -- TODO: add
, snapshotPackageSynopsis = getSynopsis gpd , snapshotPackageSynopsis = getSynopsis gpd
@ -831,7 +903,8 @@ addSnapshotPackage snapshotId compiler origin mTree mHackageCabalId isHidden fla
forM_ msnapshotPackageId $ \snapshotPackageId -> do forM_ msnapshotPackageId $ \snapshotPackageId -> do
_ <- insertDeps pid snapshotPackageId (extractDependencies compiler flags gpd) _ <- insertDeps pid snapshotPackageId (extractDependencies compiler flags gpd)
-- TODO: collect all missing dependencies and make a report -- TODO: collect all missing dependencies and make a report
insertSnapshotPackageModules snapshotPackageId (extractModuleNames gpd) forM_ cfiModuleNameIds $ \modNameId -> do
void $ P.insertBy (SnapshotPackageModule snapshotPackageId modNameId False)
getContentTreeEntryId :: getContentTreeEntryId ::
TreeId TreeId
@ -978,16 +1051,6 @@ getSnapshotPackageCabalBlob snapshotId pname =
(pn ^. PackageNameName ==. val pname)) (pn ^. PackageNameName ==. val pname))
return (blob ^. BlobContents) return (blob ^. BlobContents)
-- | Add all modules available for the package in a particular snapshot. Initially they are marked
-- as without available documentation.
insertSnapshotPackageModules ::
SnapshotPackageId -> [ModuleNameP] -> ReaderT SqlBackend (RIO env) ()
insertSnapshotPackageModules snapshotPackageId =
mapM_ $ \modName -> do
moduleId <- insertModuleSafe modName
void $ P.insertBy (SnapshotPackageModule snapshotPackageId moduleId False)
-- | Idempotent and thread safe way of adding a new module. -- | Idempotent and thread safe way of adding a new module.
insertModuleSafe :: ModuleNameP -> ReaderT SqlBackend (RIO env) ModuleNameId insertModuleSafe :: ModuleNameP -> ReaderT SqlBackend (RIO env) ModuleNameId
insertModuleSafe modName = do insertModuleSafe modName = do

2
src/Stackage/Database/Schema.hs
View File

@ -50,7 +50,7 @@ import Database.Persist.Postgresql
import Database.Persist.TH import Database.Persist.TH
import Pantry (HasPantryConfig(..), Revision) import Pantry (HasPantryConfig(..), Revision)
import Pantry.Internal.Stackage as PS (BlobId, HackageCabalId, ModuleNameId, import Pantry.Internal.Stackage as PS (BlobId, HackageCabalId, ModuleNameId,
PackageNameId, Tree(..), TreeEntry(..), PackageNameId, Tree(..),
TreeEntryId, TreeId, Unique(..), TreeEntryId, TreeId, Unique(..),
VersionId, unBlobKey) VersionId, unBlobKey)
import Pantry.Internal.Stackage (PantryConfig(..), Storage(..)) import Pantry.Internal.Stackage (PantryConfig(..), Storage(..))

3
src/Stackage/Database/Types.hs
View File

@ -51,8 +51,7 @@ import qualified Data.Text as T
import Data.Text.Read (decimal) import Data.Text.Read (decimal)
import Network.AWS (Env, HasEnv(..)) import Network.AWS (Env, HasEnv(..))
import Pantry (BlobKey(..), CabalFileInfo(..), FileSize(..), import Pantry (BlobKey(..), CabalFileInfo(..), FileSize(..),
HasPantryConfig(..), PackageIdentifierRevision(..), TreeKey(..)) HasPantryConfig(..), PantryConfig, PackageIdentifierRevision(..), TreeKey(..))
import Pantry.Internal.Stackage as Pantry (PantryConfig)
import Pantry.SHA256 (fromHexText) import Pantry.SHA256 (fromHexText)
import RIO import RIO
import RIO.Process (HasProcessContext(..), ProcessContext) import RIO.Process (HasProcessContext(..), ProcessContext)

2
src/Stackage/Snapshot/Diff.hs
View File

@ -22,7 +22,7 @@ import Data.These
import RIO import RIO
import Stackage.Database (GetStackageDatabase, SnapshotId, import Stackage.Database (GetStackageDatabase, SnapshotId,
getPackagesForSnapshot) getPackagesForSnapshot)
import Stackage.Database.Types (PackageListingInfo(..), SnapName) import Stackage.Database.Types (PackageListingInfo(..))
import Types import Types
import Web.PathPieces import Web.PathPieces

10
src/Types.hs
View File

@ -61,18 +61,16 @@ import Database.Persist
import Database.Persist.Sql (PersistFieldSql(sqlType)) import Database.Persist.Sql (PersistFieldSql(sqlType))
import qualified Distribution.ModuleName as DT (components, fromComponents, import qualified Distribution.ModuleName as DT (components, fromComponents,
validModuleComponent) validModuleComponent)
import Distribution.PackageDescription (FlagName, GenericPackageDescription) import Distribution.PackageDescription (GenericPackageDescription)
import Distribution.Parsec as DT (Parsec) import Distribution.Parsec as DT (Parsec)
import Distribution.Pretty as DT (Pretty) import Distribution.Pretty as DT (Pretty)
import qualified Distribution.Text as DT (display, simpleParse) import qualified Distribution.Text as DT (display, simpleParse)
import Distribution.Types.VersionRange (VersionRange) import Distribution.Types.VersionRange (VersionRange)
import Distribution.Version (mkVersion, versionNumbers) import Distribution.Version (mkVersion, versionNumbers)
import Pantry (Revision(..)) import Pantry (FlagName, Revision(..), packageNameString, parsePackageName,
parseVersionThrowing, parseVersion, versionString)
import Pantry.Internal.Stackage (ModuleNameP(..), PackageNameP(..), import Pantry.Internal.Stackage (ModuleNameP(..), PackageNameP(..),
SafeFilePath, VersionP(..), packageNameString, SafeFilePath, VersionP(..), unSafeFilePath)
parsePackageName, parseVersion,
parseVersionThrowing, unSafeFilePath,
versionString)
import RIO import RIO
import qualified RIO.Map as Map import qualified RIO.Map as Map
import RIO.Time (Day) import RIO.Time (Day)

2
stack.yaml
View File

@ -9,7 +9,7 @@ extra-deps:
- yesod-gitrepo-0.3.0@sha256:7aad996935065726ce615c395d735cc01dcef3993b1788f670f6bfc866085e02,1191 - yesod-gitrepo-0.3.0@sha256:7aad996935065726ce615c395d735cc01dcef3993b1788f670f6bfc866085e02,1191
- lukko-0.1.1.1@sha256:5c674bdd8a06b926ba55d872abe254155ed49a58df202b4d842b643e5ed6bcc9,4289 - lukko-0.1.1.1@sha256:5c674bdd8a06b926ba55d872abe254155ed49a58df202b4d842b643e5ed6bcc9,4289
- github: commercialhaskell/pantry - github: commercialhaskell/pantry
commit: 86462a97c4d8091993cc6e246fd0f2ae5aa608f0 commit: ed48bebc30e539280ad7e13680480be2b87b97ea
- github: fpco/casa - github: fpco/casa
commit: fc0ed26858bfc4f2966ed2dfb2871bae9266dda6 commit: fc0ed26858bfc4f2966ed2dfb2871bae9266dda6
subdirs: subdirs: