pantry-0.9.3: src/Pantry/Storage.hs
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
module Pantry.Storage
( SqlBackend
, initStorage
, withStorage
, migrateAll
, storeBlob
, loadBlob
, loadBlobById
, loadBlobBySHA
, allBlobsSource
, allHackageCabalRawPackageLocations
, allBlobsCount
, allHackageCabalCount
, getBlobKey
, loadURLBlob
, storeURLBlob
, clearHackageRevisions
, storeHackageRevision
, loadHackagePackageVersions
, loadHackagePackageVersion
, loadLatestCacheUpdate
, storeCacheUpdate
, storeHackageTarballInfo
, loadHackageTarballInfo
, getHPackBlobKeyById
, storeTree
, loadTree
, storeHPack
, loadPackageById
, getPackageNameById
, getPackageNameId
, getVersionId
, getTreeForKey
, storeHackageTree
, loadHackageTree
, loadHackageTreeKey
, storeArchiveCache
, loadArchiveCache
, storeRepoCache
, loadRepoCache
, storePreferredVersion
, loadPreferredVersion
, sinkHackagePackageNames
, loadCabalBlobKey
, hpackToCabal
, countHackageCabals
, getSnapshotCacheByHash
, getSnapshotCacheId
, storeSnapshotModuleCache
, loadExposedModulePackages
, findOrGenerateCabalFile
, PackageNameId
, PackageName
, VersionId
, ModuleNameId
, Version
, versionVersion
, Unique(..)
, EntityField(..)
-- avoid warnings
, BlobId
, Key(unBlobKey)
, HackageCabalId
, HackageCabal(..)
, HackageTarballId
, CacheUpdateId
, FilePathId
, Tree(..)
, TreeId
, TreeEntry(..)
, TreeEntryId
, ArchiveCacheId
, RepoCacheId
, PreferredVersionsId
, UrlBlobId
, SnapshotCacheId
, PackageExposedModuleId
, loadCachedTree
, CachedTree (..)
, unCachedTree
) where
import Conduit ( ConduitT, (.|), concatMapMC, mapC, runConduit )
import Data.Acquire ( with )
import Database.Persist ( ( !=.), (=.), (==.), (>.) )
import Database.Persist.Class.PersistEntity
( Entity (..), EntityField, Filter (..), Key, SelectOpt (..)
, Unique
)
import Database.Persist.Class.PersistField ( PersistField (..) )
import Database.Persist.Class.PersistQuery
( count, deleteWhere, selectFirst, selectKeysList, selectList
, selectSource, selectSourceRes, updateWhere
)
import Database.Persist.Class.PersistStore
( get, getJust, insert, insert_, update, )
import Database.Persist.Class.PersistUnique ( getBy, insertBy )
import Database.Persist.Sql ( Single (..), rawExecute, rawSql )
import Database.Persist.SqlBackend ( SqlBackend )
import Database.Persist.TH
( mkMigrate, mkPersist, persistLowerCase, share, sqlSettings
)
import Pantry.HPack ( hpack, hpackVersion )
import qualified Pantry.SHA256 as SHA256
import qualified Pantry.SQLite as SQLite
import Pantry.Types
( BlobKey, FileSize (..), FileType (..), HasPantryConfig
, Package (..), PackageNameP (..), Repo (..), Revision (..)
, SHA256, SafeFilePath, SnapshotCacheHash (..), TreeKey
, VersionP (..), connRDBMS
)
import qualified Pantry.Types as P
import Path
( Abs, Dir, File, Path, filename, fromAbsFile, fromRelFile
, parseAbsDir, toFilePath
)
import Path.IO ( createTempDir, getTempDir, listDir, removeDirRecur )
import RIO hiding ( FilePath )
import qualified RIO.ByteString as B
import RIO.Directory
( createDirectoryIfMissing, getPermissions
, setOwnerExecutable, setPermissions
)
import RIO.FilePath ( (</>), takeDirectory )
import qualified RIO.FilePath as FilePath
import qualified RIO.List as List
import qualified RIO.Map as Map
import RIO.Orphans ( HasResourceMap )
import RIO.Process ( HasProcessContext )
import qualified RIO.Text as T
import RIO.Time ( UTCTime, getCurrentTime )
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
-- Raw blobs
Blob
sha SHA256
size FileSize
contents ByteString
UniqueBlobSha sha
-- Previously downloaded blobs from given URLs.
-- May change over time, so we keep a time column too.
UrlBlob sql=url_blob
url Text
blob BlobId
time UTCTime
UniqueUrlTime url time
-- For normalization, and avoiding storing strings in a bunch of
-- tables.
PackageName
name P.PackageNameP
UniquePackageName name
Version
version P.VersionP
UniqueVersion version
FilePath
path P.SafeFilePath
UniqueSfp path
-- Secure download information for a package on Hackage. This does not
-- contain revision information, since sdist tarballs are (blessedly)
-- unmodified on Hackage.
HackageTarball
name PackageNameId
version VersionId
sha SHA256
size FileSize
UniqueHackageTarball name version
-- An individual cabal file from Hackage, representing a specific
-- revision.
HackageCabal
name PackageNameId
version VersionId
revision P.Revision
cabal BlobId
-- If available: the full tree containing the HackageTarball
-- contents with the cabal file modified.
tree TreeId Maybe
UniqueHackage name version revision
-- Any preferred-version information from Hackage
PreferredVersions
name PackageNameId
preferred Text
UniquePreferred name
-- Last time we downloaded a 01-index.tar file from Hackage and
-- updated the three previous tables.
CacheUpdate
-- When did we do the update?
time UTCTime
-- How big was the file when we updated, ignoring the last two
-- all-null 512-byte blocks.
size FileSize
-- SHA256 of the first 'size' bytes of the file
sha SHA256
-- A tree containing a Haskell package. See associated TreeEntry
-- table.
Tree
key BlobId
-- If the treeCabal field is Nothing, it means the Haskell package
-- doesn't have a corresponding cabal file for it. This may be the case
-- for haskell package referenced by git repository with only a hpack file.
cabal BlobId Maybe
cabalType FileType
name PackageNameId
version VersionId
UniqueTree key
HPack
tree TreeId
-- hpack version used for generating this cabal file
version VersionId
-- Generated cabal file for the given tree and hpack version
cabalBlob BlobId
cabalPath FilePathId
UniqueHPack tree version
-- An individual file within a Tree.
TreeEntry
tree TreeId
path FilePathId
blob BlobId
type FileType
-- Like UrlBlob, but stores the contents as a Tree.
ArchiveCache
time UTCTime
url Text
subdir Text
sha SHA256
size FileSize
tree TreeId
-- Like ArchiveCache, but for a Repo.
RepoCache
time UTCTime
url Text
type P.RepoType
commit Text
subdir Text
tree TreeId
-- Identified by sha of all immutable packages contained in a snapshot
-- and GHC version used
SnapshotCache
sha SHA256
UniqueSnapshotCache sha
PackageExposedModule
snapshotCache SnapshotCacheId
module ModuleNameId
package PackageNameId
ModuleName
name P.ModuleNameP
UniqueModule name
|]
initStorage ::
HasLogFunc env
=> Path Abs File -- ^ storage file
-> (P.Storage -> RIO env a)
-> RIO env a
initStorage =
SQLite.initStorage "Pantry" migrateAll
withStorage ::
(HasPantryConfig env, HasLogFunc env)
=> ReaderT SqlBackend (RIO env) a
-> RIO env a
withStorage action = do
storage <- view (P.pantryConfigL.to P.pcStorage)
SQLite.withStorage_ storage action
-- | This is a helper type to distinguish db queries between different rdbms
-- backends. The important part is that the affects described in this data type
-- should be semantically equivalent between the supported engines.
data RdbmsActions env a = RdbmsActions
{ raSqlite :: !(ReaderT SqlBackend (RIO env) a)
-- ^ A query that is specific to SQLite
, raPostgres :: !(ReaderT SqlBackend (RIO env) a)
-- ^ A query that is specific to PostgreSQL
}
-- | This function provides a way to create queries supported by multiple sql
-- backends.
rdbmsAwareQuery ::
RdbmsActions env a
-> ReaderT SqlBackend (RIO env) a
rdbmsAwareQuery RdbmsActions {raSqlite, raPostgres} = do
rdbms <- Pantry.Types.connRDBMS <$> ask
case rdbms of
"postgresql" -> raPostgres
"sqlite" -> raSqlite
_ -> error $ "rdbmsAwareQuery: unsupported rdbms '" ++ T.unpack rdbms ++ "'"
getPackageNameById ::
PackageNameId
-> ReaderT SqlBackend (RIO env) (Maybe P.PackageName)
getPackageNameById = fmap (unPackageNameP . packageNameName <$>) . get
getPackageNameId ::
P.PackageName
-> ReaderT SqlBackend (RIO env) PackageNameId
getPackageNameId =
fmap (either entityKey id) . insertBy . PackageName . PackageNameP
getVersionId ::
P.Version
-> ReaderT SqlBackend (RIO env) VersionId
getVersionId = fmap (either entityKey id) . insertBy . Version . VersionP
storeBlob ::
ByteString
-> ReaderT SqlBackend (RIO env) (BlobId, BlobKey)
storeBlob bs = do
let sha = SHA256.hashBytes bs
size = FileSize $ fromIntegral $ B.length bs
keys <- selectKeysList [BlobSha ==. sha] []
key <-
case keys of
[] ->
rdbmsAwareQuery
RdbmsActions
{ raSqlite =
insert Blob {blobSha = sha, blobSize = size, blobContents = bs}
, raPostgres = do
rawExecute
"INSERT INTO blob(sha, size, contents) VALUES (?, ?, ?) ON \
\CONFLICT DO NOTHING"
[ toPersistValue sha
, toPersistValue size
, toPersistValue bs
]
rawSql
"SELECT blob.id FROM blob WHERE blob.sha = ?"
[toPersistValue sha] >>= \case
[Single key] -> pure key
_ -> error
"soreBlob: there was a critical problem storing a blob."
}
key:rest -> assert (null rest) (pure key)
pure (key, P.BlobKey sha size)
loadBlob ::
HasLogFunc env
=> BlobKey
-> ReaderT SqlBackend (RIO env) (Maybe ByteString)
loadBlob (P.BlobKey sha size) = do
ment <- getBy $ UniqueBlobSha sha
case ment of
Nothing -> pure Nothing
Just (Entity _ bt)
| blobSize bt == size -> pure $ Just $ blobContents bt
| otherwise ->
Nothing <$ lift (logWarn $
"Mismatched blob size detected for SHA " <> display sha <>
". Expected size: " <> display size <>
". Actual size: " <> display (blobSize bt))
loadBlobBySHA :: SHA256 -> ReaderT SqlBackend (RIO env) (Maybe BlobId)
loadBlobBySHA sha = listToMaybe <$> selectKeysList [BlobSha ==. sha] []
loadBlobById :: BlobId -> ReaderT SqlBackend (RIO env) ByteString
loadBlobById bid = do
mbt <- get bid
case mbt of
Nothing -> error "loadBlobById: ID doesn't exist in database"
Just bt -> pure $ blobContents bt
allBlobsSource ::
HasResourceMap env
=> Maybe BlobId
-- ^ For some x, yield blob whose id>x.
-> ConduitT () (BlobId, ByteString) (ReaderT SqlBackend (RIO env)) ()
allBlobsSource mblobId =
selectSource [BlobId >. blobId | Just blobId <- [mblobId]] [Asc BlobId] .|
mapC (entityKey &&& blobContents . entityVal)
-- | Pull all hackage cabal entries from the database as
-- 'RawPackageLocationImmutable'. We do a manual join rather than dropping to
-- raw SQL, and Esqueleto would add more deps.
allHackageCabalRawPackageLocations ::
HasResourceMap env
=> Maybe HackageCabalId
-- ^ For some x, yield cabals whose id>x.
-> ReaderT
SqlBackend (RIO env)
(Map.Map HackageCabalId P.RawPackageLocationImmutable)
allHackageCabalRawPackageLocations mhackageId = do
hackageCabals :: Map HackageCabalId HackageCabal <-
selectTuples
[HackageCabalId >. hackageId | Just hackageId <- [mhackageId]]
[]
packageNames :: Map PackageNameId PackageName <- selectTuples [] []
versions :: Map VersionId Version <- selectTuples [] []
for
hackageCabals
(\hackageCabal ->
case Map.lookup (hackageCabalName hackageCabal) packageNames of
Nothing -> error "no such package name"
Just packageName ->
let P.PackageNameP packageName' = packageNameName packageName
in case Map.lookup (hackageCabalVersion hackageCabal) versions of
Nothing -> error "no such version"
Just version ->
let P.VersionP version' = versionVersion version
in do mtree <-
case hackageCabalTree hackageCabal of
Just key -> selectFirst [TreeId ==. key] []
Nothing -> pure Nothing
mblobKey <-
maybe
(pure Nothing)
((fmap Just . getBlobKey) . treeKey . entityVal)
mtree
pure
(P.RPLIHackage
(P.PackageIdentifierRevision
packageName'
version'
(P.CFIRevision
(hackageCabalRevision hackageCabal)))
(fmap P.TreeKey mblobKey)))
where
selectTuples pred sort =
fmap (Map.fromList . map tuple) (selectList pred sort)
tuple (Entity k v) = (k, v)
allBlobsCount :: Maybe BlobId -> ReaderT SqlBackend (RIO env) Int
allBlobsCount mblobId = count [BlobId >. blobId | Just blobId <- [mblobId]]
allHackageCabalCount :: Maybe HackageCabalId -> ReaderT SqlBackend (RIO env) Int
allHackageCabalCount mhackageCabalId =
count
[ HackageCabalId >. hackageCabalId
| Just hackageCabalId <- [mhackageCabalId]
]
getBlobKey :: BlobId -> ReaderT SqlBackend (RIO env) BlobKey
getBlobKey bid = do
res <- rawSql "SELECT sha, size FROM blob WHERE id=?" [toPersistValue bid]
case res of
[] -> error $ "getBlobKey failed due to missing ID: " ++ show bid
[(Single sha, Single size)] -> pure $ P.BlobKey sha size
_ -> error $ "getBlobKey failed due to non-unique ID: " ++ show (bid, res)
getBlobId :: BlobKey -> ReaderT SqlBackend (RIO env) (Maybe BlobId)
getBlobId (P.BlobKey sha size) = do
res <- rawSql "SELECT id FROM blob WHERE sha=? AND size=?"
[toPersistValue sha, toPersistValue size]
pure $ listToMaybe $ map unSingle res
loadURLBlob :: Text -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
loadURLBlob url = do
ment <- rawSql
"SELECT blob.contents\n\
\FROM blob, url_blob\n\
\WHERE url=?\
\ AND url_blob.blob=blob.id\n\
\ ORDER BY url_blob.time DESC"
[toPersistValue url]
case ment of
[] -> pure Nothing
(Single bs) : _ -> pure $ Just bs
storeURLBlob :: Text -> ByteString -> ReaderT SqlBackend (RIO env) ()
storeURLBlob url blob = do
(blobId, _) <- storeBlob blob
now <- getCurrentTime
insert_ UrlBlob
{ urlBlobUrl = url
, urlBlobBlob = blobId
, urlBlobTime = now
}
clearHackageRevisions :: ReaderT SqlBackend (RIO env) ()
clearHackageRevisions = deleteWhere ([] :: [Filter HackageCabal])
storeHackageRevision ::
P.PackageName
-> P.Version
-> BlobId
-> ReaderT SqlBackend (RIO env) ()
storeHackageRevision name version key = do
nameid <- getPackageNameId name
versionid <- getVersionId version
rev <- count
[ HackageCabalName ==. nameid
, HackageCabalVersion ==. versionid
]
insert_ HackageCabal
{ hackageCabalName = nameid
, hackageCabalVersion = versionid
, hackageCabalRevision = Revision (fromIntegral rev)
, hackageCabalCabal = key
, hackageCabalTree = Nothing
}
loadHackagePackageVersions ::
P.PackageName
-> ReaderT SqlBackend (RIO env) (Map P.Version (Map Revision BlobKey))
loadHackagePackageVersions name = do
nameid <- getPackageNameId name
-- would be better with esqueleto
Map.fromListWith Map.union . map go <$> rawSql
"SELECT hackage.revision, version.version, blob.sha, blob.size\n\
\FROM hackage_cabal as hackage, version, blob\n\
\WHERE hackage.name=?\n\
\AND hackage.version=version.id\n\
\AND hackage.cabal=blob.id"
[toPersistValue nameid]
where
go (Single revision, Single (P.VersionP version), Single key, Single size) =
(version, Map.singleton revision (P.BlobKey key size))
loadHackagePackageVersion ::
P.PackageName
-> P.Version
-> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, P.BlobKey))
loadHackagePackageVersion name version = do
nameid <- getPackageNameId name
versionid <- getVersionId version
-- would be better with esqueleto
Map.fromList . map go <$> rawSql
"SELECT hackage.revision, blob.sha, blob.size, blob.id\n\
\FROM hackage_cabal as hackage, version, blob\n\
\WHERE hackage.name=?\n\
\AND hackage.version=?\n\
\AND hackage.cabal=blob.id"
[toPersistValue nameid, toPersistValue versionid]
where
go (Single revision, Single sha, Single size, Single bid) =
(revision, (bid, P.BlobKey sha size))
loadLatestCacheUpdate ::
ReaderT SqlBackend (RIO env) (Maybe (FileSize, SHA256))
loadLatestCacheUpdate = fmap go <$> selectFirst [] [Desc CacheUpdateTime]
where
go (Entity _ cu) = (cacheUpdateSize cu, cacheUpdateSha cu)
storeCacheUpdate :: FileSize -> SHA256 -> ReaderT SqlBackend (RIO env) ()
storeCacheUpdate size sha = do
now <- getCurrentTime
insert_ CacheUpdate
{ cacheUpdateTime = now
, cacheUpdateSize = size
, cacheUpdateSha = sha
}
storeHackageTarballInfo ::
P.PackageName
-> P.Version
-> SHA256
-> FileSize
-> ReaderT SqlBackend (RIO env) ()
storeHackageTarballInfo name version sha size = do
nameid <- getPackageNameId name
versionid <- getVersionId version
void $ insertBy HackageTarball
{ hackageTarballName = nameid
, hackageTarballVersion = versionid
, hackageTarballSha = sha
, hackageTarballSize = size
}
loadHackageTarballInfo ::
P.PackageName
-> P.Version
-> ReaderT SqlBackend (RIO env) (Maybe (SHA256, FileSize))
loadHackageTarballInfo name version = do
nameid <- getPackageNameId name
versionid <- getVersionId version
fmap go <$> getBy (UniqueHackageTarball nameid versionid)
where
go (Entity _ ht) = (hackageTarballSha ht, hackageTarballSize ht)
storeCabalFile ::
ByteString
-> P.PackageName
-> ReaderT SqlBackend (RIO env) BlobId
storeCabalFile cabalBS pkgName = do
(bid, _) <- storeBlob cabalBS
let cabalFile = P.cabalFileName pkgName
_ <- insertBy FilePath {filePathPath = cabalFile}
pure bid
loadFilePath ::
SafeFilePath
-> ReaderT SqlBackend (RIO env) (Entity FilePath)
loadFilePath path = do
fp <- getBy $ UniqueSfp path
case fp of
Nothing -> error $
"loadFilePath: No row found for " <> T.unpack (P.unSafeFilePath path)
Just record -> pure record
loadHPackTreeEntity :: TreeId -> ReaderT SqlBackend (RIO env) (Entity TreeEntry)
loadHPackTreeEntity tid = do
filepath <- loadFilePath P.hpackSafeFilePath
let filePathId :: FilePathId = entityKey filepath
hpackTreeEntry <-
selectFirst [TreeEntryTree ==. tid, TreeEntryPath ==. filePathId] []
case hpackTreeEntry of
Nothing -> error $
"loadHPackTreeEntity: No package.yaml file found in TreeEntry for TreeId: "
++ show tid
Just record -> pure record
storeHPack ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> P.RawPackageLocationImmutable
-> TreeId
-> ReaderT SqlBackend (RIO env) (Key HPack)
storeHPack rpli tid = do
vid <- hpackVersionId
hpackRecord <- getBy (UniqueHPack tid vid)
case hpackRecord of
Nothing -> generateHPack rpli tid vid
Just record -> pure $ entityKey record
loadCabalBlobKey :: HPackId -> ReaderT SqlBackend (RIO env) BlobKey
loadCabalBlobKey hpackId = do
hpackRecord <- getJust hpackId
getBlobKey $ hPackCabalBlob hpackRecord
generateHPack ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> P.RawPackageLocationImmutable -- ^ for exceptions
-> TreeId
-> VersionId
-> ReaderT SqlBackend (RIO env) (Key HPack)
generateHPack rpli tid vid = do
tree <- getTree tid
(pkgName, cabalBS) <- hpackToCabalS rpli tree
bid <- storeCabalFile cabalBS pkgName
let cabalFile = P.cabalFileName pkgName
fid <- insertBy FilePath {filePathPath = cabalFile}
let hpackRecord =
HPack
{ hPackTree = tid
, hPackVersion = vid
, hPackCabalBlob = bid
, hPackCabalPath = either entityKey id fid
}
either entityKey id <$> insertBy hpackRecord
hpackVersionId ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> ReaderT SqlBackend (RIO env) VersionId
hpackVersionId = do
hpackSoftwareVersion <- lift hpackVersion
fmap (either entityKey id) $
insertBy $
Version {versionVersion = P.VersionP hpackSoftwareVersion}
getFilePathId :: SafeFilePath -> ReaderT SqlBackend (RIO env) FilePathId
getFilePathId sfp =
selectKeysList [FilePathPath ==. sfp] [] >>= \case
[fpId] -> pure fpId
[] ->
rdbmsAwareQuery
RdbmsActions
{ raSqlite = insert $ FilePath sfp
, raPostgres = do
rawExecute
"INSERT INTO file_path(path) VALUES (?) ON CONFLICT DO NOTHING"
[toPersistValue sfp]
rawSql
"SELECT id FROM file_path WHERE path = ?"
[toPersistValue sfp] >>= \case
[Single key] -> pure key
_ -> error
"getFilePathId: there was a critical problem storing a blob."
}
_ ->
error $
"getFilePathId: FilePath unique constraint key is violated for: " ++ fp
where
fp = T.unpack (P.unSafeFilePath sfp)
-- | A tree that has already been stored in the database
newtype CachedTree
= CachedTreeMap (Map SafeFilePath (P.TreeEntry, BlobId))
deriving Show
unCachedTree :: CachedTree -> P.Tree
unCachedTree (CachedTreeMap m) = P.TreeMap $ fst <$> m
storeTree ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> P.RawPackageLocationImmutable -- ^ for exceptions
-> P.PackageIdentifier
-> CachedTree
-> P.BuildFile
-> ReaderT SqlBackend (RIO env) (TreeId, P.TreeKey)
storeTree rpli (P.PackageIdentifier name version) tree@(CachedTreeMap m) buildFile = do
(bid, blobKey) <- storeBlob $ P.renderTree $ unCachedTree tree
(cabalid, ftype) <- case buildFile of
P.BFHpack (P.TreeEntry _ ftype) -> pure (Nothing, ftype)
P.BFCabal _ (P.TreeEntry (P.BlobKey btypeSha _) ftype) -> do
buildTypeid <- loadBlobBySHA btypeSha
buildid <-
case buildTypeid of
Just buildId -> pure buildId
Nothing -> error $
"storeTree: "
++ show buildFile
++ " BlobKey not found: "
++ show (tree, btypeSha)
pure (Just buildid, ftype)
nameid <- getPackageNameId name
versionid <- getVersionId version
etid <- insertBy Tree
{ treeKey = bid
, treeCabal = cabalid
, treeCabalType = ftype
, treeName = nameid
, treeVersion = versionid
}
(tid, pTreeKey) <- case etid of
Left (Entity tid _) -> pure (tid, P.TreeKey blobKey) -- already in database, assume it matches
Right tid -> do
for_ (Map.toList m) $ \(sfp, (P.TreeEntry _blobKey ft, bid')) -> do
sfpid <- getFilePathId sfp
insert_ TreeEntry
{ treeEntryTree = tid
, treeEntryPath = sfpid
, treeEntryBlob = bid'
, treeEntryType = ft
}
pure (tid, P.TreeKey blobKey)
case buildFile of
P.BFHpack _ -> void $ storeHPack rpli tid
P.BFCabal _ _ -> pure ()
pure (tid, pTreeKey)
getTree :: TreeId -> ReaderT SqlBackend (RIO env) P.Tree
getTree tid = do
(mts :: Maybe Tree) <- get tid
ts <-
case mts of
Nothing ->
error $ "getTree: invalid foreign key " ++ show tid
Just ts -> pure ts
loadTreeByEnt $ Entity tid ts
loadTree :: P.TreeKey -> ReaderT SqlBackend (RIO env) (Maybe P.Tree)
loadTree key = do
ment <- getTreeForKey key
case ment of
Nothing -> pure Nothing
Just ent -> Just <$> loadTreeByEnt ent
getTreeForKey ::
TreeKey
-> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
getTreeForKey (P.TreeKey key) = do
mbid <- getBlobId key
case mbid of
Nothing -> pure Nothing
Just bid -> getBy $ UniqueTree bid
loadPackageById ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> P.RawPackageLocationImmutable -- ^ for exceptions
-> TreeId
-> ReaderT SqlBackend (RIO env) Package
loadPackageById rpli tid = do
(mts :: Maybe Tree) <- get tid
ts <- case mts of
Nothing ->
error $ "loadPackageById: invalid foreign key " ++ show tid
Just ts -> pure ts
(tree :: P.Tree) <- loadTreeByEnt $ Entity tid ts
(blobKey :: BlobKey) <- getBlobKey $ treeKey ts
(mname :: Maybe PackageName) <- get $ treeName ts
name <- case mname of
Nothing -> error $
"loadPackageByid: invalid foreign key " ++ show (treeName ts)
Just (PackageName (P.PackageNameP name)) -> pure name
mversion <- get $ treeVersion ts
version <- case mversion of
Nothing -> error $
"loadPackageByid: invalid foreign key " ++ show (treeVersion ts)
Just (Version (P.VersionP version)) -> pure version
let ident = P.PackageIdentifier name version
(packageEntry, mtree) <- case treeCabal ts of
Just keyBlob -> do
cabalKey <- getBlobKey keyBlob
pure
( P.PCCabalFile $ P.TreeEntry cabalKey (treeCabalType ts)
, tree)
Nothing -> do
hpackVid <- hpackVersionId
hpackEntity <- getBy (UniqueHPack tid hpackVid)
let (P.TreeMap tmap) = tree
cabalFile = P.cabalFileName name
case hpackEntity of
Nothing -> do
-- This case will happen when you either update stack with a new hpack
-- version or use different hpack version via --with-hpack option.
(hpackId :: HPackId) <- storeHPack rpli tid
hpackRecord <- getJust hpackId
getHPackCabalFile hpackRecord ts tmap cabalFile
Just (Entity _ item) ->
getHPackCabalFile item ts tmap cabalFile
pure
Package
{ packageTreeKey = P.TreeKey blobKey
, packageTree = mtree
, packageCabalEntry = packageEntry
, packageIdent = ident
}
getHPackBlobKey :: HPack -> ReaderT SqlBackend (RIO env) BlobKey
getHPackBlobKey hpackRecord = do
let treeId = hPackTree hpackRecord
hpackEntity <- loadHPackTreeEntity treeId
getBlobKey (treeEntryBlob $ entityVal hpackEntity)
getHPackBlobKeyById :: HPackId -> ReaderT SqlBackend (RIO env) BlobKey
getHPackBlobKeyById hpackId = do
hpackRecord <- getJust hpackId
getHPackBlobKey hpackRecord
getHPackCabalFile ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> HPack
-> Tree
-> Map SafeFilePath P.TreeEntry
-> SafeFilePath
-> ReaderT SqlBackend (RIO env) (P.PackageCabal, P.Tree)
getHPackCabalFile hpackRecord ts tmap cabalFile = do
cabalKey <- getBlobKey (hPackCabalBlob hpackRecord)
hpackKey <- getHPackBlobKey hpackRecord
hpackSoftwareVersion <- lift hpackVersion
let fileType = treeCabalType ts
cbTreeEntry = P.TreeEntry cabalKey fileType
hpackTreeEntry = P.TreeEntry hpackKey fileType
tree = P.TreeMap $ Map.insert cabalFile cbTreeEntry tmap
pure
( P.PCHpack $
P.PHpack
{ P.phOriginal = hpackTreeEntry
, P.phGenerated = cbTreeEntry
, P.phVersion = hpackSoftwareVersion
}
, tree
)
loadTreeByEnt :: Entity Tree -> ReaderT SqlBackend (RIO env) P.Tree
loadTreeByEnt (Entity tid _t) = do
entries <- rawSql
"SELECT file_path.path, blob.sha, blob.size, tree_entry.type\n\
\FROM tree_entry, blob, file_path\n\
\WHERE tree_entry.tree=?\n\
\AND tree_entry.blob=blob.id\n\
\AND tree_entry.path=file_path.id"
[toPersistValue tid]
pure $ P.TreeMap $ Map.fromList $ map
(\(Single sfp, Single sha, Single size, Single ft) ->
(sfp, P.TreeEntry (P.BlobKey sha size) ft))
entries
storeHackageTree ::
P.PackageName
-> P.Version
-> BlobId
-> P.TreeKey
-> ReaderT SqlBackend (RIO env) ()
storeHackageTree name version cabal treeKey' = do
nameid <- getPackageNameId name
versionid <- getVersionId version
ment <- getTreeForKey treeKey'
for_ ment $ \ent -> updateWhere
[ HackageCabalName ==. nameid
, HackageCabalVersion ==. versionid
, HackageCabalCabal ==. cabal
]
[HackageCabalTree =. Just (entityKey ent)]
loadHackageTreeKey ::
P.PackageName
-> P.Version
-> SHA256
-> ReaderT SqlBackend (RIO env) (Maybe TreeKey)
loadHackageTreeKey name ver sha = do
res <- rawSql
"SELECT treeblob.sha, treeblob.size\n\
\FROM blob as treeblob, blob as cabalblob, package_name, version, hackage_cabal, tree\n\
\WHERE package_name.name=?\n\
\AND version.version=?\n\
\AND cabalblob.sha=?\n\
\AND hackage_cabal.name=package_name.id\n\
\AND hackage_cabal.version=version.id\n\
\AND hackage_cabal.cabal=cabalblob.id\n\
\AND hackage_cabal.tree=tree.id\n\
\AND tree.key=treeblob.id"
[ toPersistValue $ P.PackageNameP name
, toPersistValue $ P.VersionP ver
, toPersistValue sha
]
case res of
[] -> pure Nothing
(Single treesha, Single size):_ ->
pure $ Just $ P.TreeKey $ P.BlobKey treesha size
loadHackageTree ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> P.RawPackageLocationImmutable -- ^ for exceptions
-> P.PackageName
-> P.Version
-> BlobId
-> ReaderT SqlBackend (RIO env) (Maybe Package)
loadHackageTree rpli name ver bid = do
nameid <- getPackageNameId name
versionid <- getVersionId ver
ment <- selectFirst
[ HackageCabalName ==. nameid
, HackageCabalVersion ==. versionid
, HackageCabalCabal ==. bid
, HackageCabalTree !=. Nothing
]
[]
case ment of
Nothing -> pure Nothing
Just (Entity _ hc) ->
case hackageCabalTree hc of
Nothing -> assert False $ pure Nothing
Just tid -> Just <$> loadPackageById rpli tid
storeArchiveCache ::
Text -- ^ URL
-> Text -- ^ subdir
-> SHA256
-> FileSize
-> P.TreeKey
-> ReaderT SqlBackend (RIO env) ()
storeArchiveCache url subdir sha size treeKey' = do
now <- getCurrentTime
ment <- getTreeForKey treeKey'
for_ ment $ \ent -> insert_ ArchiveCache
{ archiveCacheTime = now
, archiveCacheUrl = url
, archiveCacheSubdir = subdir
, archiveCacheSha = sha
, archiveCacheSize = size
, archiveCacheTree = entityKey ent
}
loadArchiveCache ::
Text -- ^ URL
-> Text -- ^ subdir
-> ReaderT SqlBackend (RIO env) [(SHA256, FileSize, TreeId)]
loadArchiveCache url subdir = map go <$> selectList
[ ArchiveCacheUrl ==. url
, ArchiveCacheSubdir ==. subdir
]
[Desc ArchiveCacheTime]
where
go (Entity _ ac) = (archiveCacheSha ac, archiveCacheSize ac, archiveCacheTree ac)
storeRepoCache ::
Repo
-> Text -- ^ subdir
-> TreeId
-> ReaderT SqlBackend (RIO env) ()
storeRepoCache repo subdir tid = do
now <- getCurrentTime
insert_ RepoCache
{ repoCacheTime = now
, repoCacheUrl = repoUrl repo
, repoCacheType = repoType repo
, repoCacheCommit = repoCommit repo
, repoCacheSubdir = subdir
, repoCacheTree = tid
}
loadRepoCache ::
Repo
-> ReaderT SqlBackend (RIO env) (Maybe TreeId)
loadRepoCache repo = fmap (repoCacheTree . entityVal) <$> selectFirst
[ RepoCacheUrl ==. repoUrl repo
, RepoCacheType ==. repoType repo
, RepoCacheCommit ==. repoCommit repo
, RepoCacheSubdir ==. repoSubdir repo
]
[Desc RepoCacheTime]
storePreferredVersion ::
P.PackageName
-> Text
-> ReaderT SqlBackend (RIO env) ()
storePreferredVersion name p = do
nameid <- getPackageNameId name
ment <- getBy $ UniquePreferred nameid
case ment of
Nothing -> insert_ PreferredVersions
{ preferredVersionsName = nameid
, preferredVersionsPreferred = p
}
Just (Entity pid _) -> update pid [PreferredVersionsPreferred =. p]
loadPreferredVersion ::
P.PackageName
-> ReaderT SqlBackend (RIO env) (Maybe Text)
loadPreferredVersion name = do
nameid <- getPackageNameId name
fmap (preferredVersionsPreferred . entityVal) <$> getBy (UniquePreferred nameid)
sinkHackagePackageNames ::
(P.PackageName -> Bool)
-> ConduitT P.PackageName Void (ReaderT SqlBackend (RIO env)) a
-> ReaderT SqlBackend (RIO env) a
sinkHackagePackageNames predicate sink = do
acqSrc <- selectSourceRes [] []
with acqSrc $ \src -> runConduit
$ src
.| concatMapMC go
.| sink
where
go (Entity nameid (PackageName (PackageNameP name)))
| predicate name = do
-- Make sure it's actually on Hackage. Would be much more efficient with
-- some raw SQL and an inner join, but we don't have a Conduit version
-- of rawSql.
onHackage <- checkOnHackage nameid
pure $ if onHackage then Just name else Nothing
| otherwise = pure Nothing
checkOnHackage nameid = do
cnt <- count [HackageCabalName ==. nameid]
pure $ cnt > 0
-- | Get the filename for the cabal file in the given directory.
--
-- If no .cabal file is present, or more than one is present, an exception is
-- thrown via 'throwM'.
--
-- If the directory contains a file named package.yaml, hpack is used to
-- generate a .cabal file from it.
findOrGenerateCabalFile ::
forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> Path Abs Dir -- ^ package directory
-> RIO env (P.PackageName, Path Abs File)
findOrGenerateCabalFile pkgDir = do
hpack pkgDir
files <- filter (flip hasExtension "cabal" . toFilePath) . snd
<$> listDir pkgDir
-- If there are multiple files, ignore files that start with ".". On unix-like
-- environments these are hidden, and this character is not valid in package
-- names. The main goal is to ignore emacs lock files - see
-- https://github.com/commercialhaskell/stack/issues/1897.
let isHidden ('.':_) = True
isHidden _ = False
case filter (not . isHidden . fromRelFile . filename) files of
[] -> throwIO $ P.NoCabalFileFound pkgDir
[x] -> maybe
(throwIO $ P.InvalidCabalFilePath x)
(\pn -> pure (pn, x)) $
List.stripSuffix ".cabal" (toFilePath (filename x)) >>=
P.parsePackageName
_:_ -> throwIO $ P.MultipleCabalFilesFound pkgDir files
where
hasExtension fp x = FilePath.takeExtension fp == "." ++ x
-- | Similar to 'hpackToCabal' but doesn't require a new connection to database.
hpackToCabalS ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> P.RawPackageLocationImmutable -- ^ for exceptions
-> P.Tree
-> ReaderT SqlBackend (RIO env) (P.PackageName, ByteString)
hpackToCabalS rpli tree = do
tmpDir <- lift $ do
tdir <- getTempDir
createTempDir tdir "hpack-pkg-dir"
unpackTreeToDir rpli tmpDir tree
(packageName, cfile) <- lift $ findOrGenerateCabalFile tmpDir
!bs <- lift $ B.readFile (fromAbsFile cfile)
lift $ removeDirRecur tmpDir
pure (packageName, bs)
hpackToCabal ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> P.RawPackageLocationImmutable -- ^ for exceptions
-> P.Tree
-> RIO env (P.PackageName, ByteString)
hpackToCabal rpli tree = withSystemTempDirectory "hpack-pkg-dir" $ \tmpdir -> do
tdir <- parseAbsDir tmpdir
withStorage $ unpackTreeToDir rpli tdir tree
(packageName, cfile) <- findOrGenerateCabalFile tdir
bs <- B.readFile (fromAbsFile cfile)
pure (packageName, bs)
unpackTreeToDir ::
(HasPantryConfig env, HasLogFunc env)
=> P.RawPackageLocationImmutable -- ^ for exceptions
-> Path Abs Dir -- ^ dest dir, will be created if necessary
-> P.Tree
-> ReaderT SqlBackend (RIO env) ()
unpackTreeToDir rpli (toFilePath -> dir) (P.TreeMap m) = do
for_ (Map.toList m) $ \(sfp, P.TreeEntry blobKey ft) -> do
let dest = dir </> T.unpack (P.unSafeFilePath sfp)
createDirectoryIfMissing True $ takeDirectory dest
mbs <- loadBlob blobKey
case mbs of
Nothing -> do
-- TODO when we have pantry wire stuff, try downloading
throwIO $ P.TreeReferencesMissingBlob rpli sfp blobKey
Just bs -> do
B.writeFile dest bs
case ft of
FTNormal -> pure ()
FTExecutable -> liftIO $ do
perms <- getPermissions dest
setPermissions dest $ setOwnerExecutable True perms
countHackageCabals :: ReaderT SqlBackend (RIO env) Int
countHackageCabals = do
res <- rawSql
"SELECT COUNT(*)\n\
\FROM hackage_cabal"
[]
case res of
[] -> pure 0
(Single n):_ ->
pure n
getSnapshotCacheByHash ::
SnapshotCacheHash
-> ReaderT SqlBackend (RIO env) (Maybe SnapshotCacheId)
getSnapshotCacheByHash =
fmap (fmap entityKey) . getBy . UniqueSnapshotCache . unSnapshotCacheHash
getSnapshotCacheId ::
SnapshotCacheHash
-> ReaderT SqlBackend (RIO env) SnapshotCacheId
getSnapshotCacheId =
fmap (either entityKey id) . insertBy . SnapshotCache . unSnapshotCacheHash
getModuleNameId ::
P.ModuleName
-> ReaderT SqlBackend (RIO env) ModuleNameId
getModuleNameId =
fmap (either entityKey id) . insertBy . ModuleName . P.ModuleNameP
storeSnapshotModuleCache ::
SnapshotCacheId
-> Map P.PackageName (Set P.ModuleName)
-> ReaderT SqlBackend (RIO env) ()
storeSnapshotModuleCache cache packageModules =
forM_ (Map.toList packageModules) $ \(pn, modules) -> do
package <- getPackageNameId pn
forM_ modules $ \m -> do
moduleName <- getModuleNameId m
insert_ PackageExposedModule
{ packageExposedModuleSnapshotCache = cache
, packageExposedModulePackage = package
, packageExposedModuleModule = moduleName
}
loadExposedModulePackages ::
SnapshotCacheId
-> P.ModuleName
-> ReaderT SqlBackend (RIO env) [P.PackageName]
loadExposedModulePackages cacheId mName =
map go <$> rawSql
"SELECT package_name.name\n\
\FROM package_name, package_exposed_module, module_name\n\
\WHERE module_name.name=?\n\
\AND package_exposed_module.snapshot_cache=?\n\
\AND module_name.id=package_exposed_module.module\n\
\AND package_name.id=package_exposed_module.package"
[ toPersistValue (P.ModuleNameP mName)
, toPersistValue cacheId
]
where
go (Single (P.PackageNameP m)) = m
newtype LoadCachedTreeException = MissingBlob BlobKey
deriving (Show, Typeable)
instance Exception LoadCachedTreeException
-- | Ensure that all blobs needed for this package are present in the cache
loadCachedTree ::
forall env. P.Tree
-> ReaderT SqlBackend (RIO env) (Either LoadCachedTreeException CachedTree)
loadCachedTree (P.TreeMap m) =
try $ CachedTreeMap <$> traverse loadEntry m
where
loadEntry :: P.TreeEntry -> ReaderT SqlBackend (RIO env) (P.TreeEntry, BlobId)
loadEntry te = (te, ) <$> loadBlob' (P.teBlob te)
loadBlob' :: BlobKey -> ReaderT SqlBackend (RIO env) BlobId
loadBlob' blobKey@(P.BlobKey sha _) = do
mbid <- loadBlobBySHA sha
case mbid of
Nothing -> throwIO $ MissingBlob blobKey
Just bid -> pure bid