1{-# LANGUAGE TypeApplications #-}
2{-# LANGUAGE NamedFieldPuns #-}
3{-# LANGUAGE NoImplicitPrelude #-}
4{-# LANGUAGE BangPatterns #-}
5{-# LANGUAGE TemplateHaskell #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE QuasiQuotes #-}
8{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE MultiParamTypeClasses #-}
10{-# LANGUAGE GeneralizedNewtypeDeriving #-}
11{-# LANGUAGE GADTs #-}
12{-# LANGUAGE OverloadedStrings #-}
13{-# LANGUAGE ViewPatterns #-}
14{-# LANGUAGE LambdaCase #-}
15{-# LANGUAGE UndecidableInstances #-}
16{-# LANGUAGE DerivingStrategies #-}
17{-# LANGUAGE StandaloneDeriving #-}
18{-# LANGUAGE TupleSections #-}
19{-# LANGUAGE DataKinds #-}
20{-# LANGUAGE FlexibleInstances #-}
21module Pantry.Storage
22  ( SqlBackend
23  , initStorage
24  , withStorage
25  , migrateAll
26  , storeBlob
27  , loadBlob
28  , loadBlobById
29  , loadBlobBySHA
30  , allBlobsSource
31  , allHackageCabalRawPackageLocations
32  , allBlobsCount
33  , allHackageCabalCount
34  , getBlobKey
35  , loadURLBlob
36  , storeURLBlob
37  , clearHackageRevisions
38  , storeHackageRevision
39  , loadHackagePackageVersions
40  , loadHackagePackageVersion
41  , loadLatestCacheUpdate
42  , storeCacheUpdate
43  , storeHackageTarballInfo
44  , loadHackageTarballInfo
45  , getHPackBlobKeyById
46  , storeTree
47  , loadTree
48  , storeHPack
49  , loadPackageById
50  , getPackageNameById
51  , getPackageNameId
52  , getVersionId
53  , getTreeForKey
54  , storeHackageTree
55  , loadHackageTree
56  , loadHackageTreeKey
57  , storeArchiveCache
58  , loadArchiveCache
59  , storeRepoCache
60  , loadRepoCache
61  , storePreferredVersion
62  , loadPreferredVersion
63  , sinkHackagePackageNames
64  , loadCabalBlobKey
65  , hpackToCabal
66  , countHackageCabals
67  , getSnapshotCacheByHash
68  , getSnapshotCacheId
69  , storeSnapshotModuleCache
70  , loadExposedModulePackages
71  , PackageNameId
72  , PackageName
73  , VersionId
74  , ModuleNameId
75  , Version
76  , versionVersion
77  , Unique(..)
78  , EntityField(..)
79    -- avoid warnings
80  , BlobId
81  , Key(unBlobKey)
82  , HackageCabalId
83  , HackageCabal(..)
84  , HackageTarballId
85  , CacheUpdateId
86  , FilePathId
87  , Tree(..)
88  , TreeId
89  , TreeEntry(..)
90  , TreeEntryId
91  , ArchiveCacheId
92  , RepoCacheId
93  , PreferredVersionsId
94  , UrlBlobId
95  , SnapshotCacheId
96  , PackageExposedModuleId
97  , loadCachedTree
98  , CachedTree (..)
99  , unCachedTree
100  ) where
101
102import RIO hiding (FilePath)
103import RIO.Process
104import qualified RIO.ByteString as B
105import qualified Pantry.Types as P
106import qualified RIO.List as List
107import qualified RIO.FilePath as FilePath
108import RIO.FilePath ((</>), takeDirectory)
109import RIO.Directory (createDirectoryIfMissing, setPermissions, getPermissions, setOwnerExecutable)
110import Database.Persist
111import Database.Persist.Sqlite
112import Database.Persist.TH
113import RIO.Orphans (HasResourceMap)
114import qualified Pantry.SHA256 as SHA256
115import qualified RIO.Map as Map
116import qualified RIO.Text as T
117import RIO.Time (UTCTime, getCurrentTime)
118import Path (Path, Abs, File, Dir, toFilePath, filename, parseAbsDir, fromAbsFile, fromRelFile)
119import Path.IO (listDir, createTempDir, getTempDir, removeDirRecur)
120import Pantry.HPack (hpackVersion, hpack)
121import Conduit
122import Data.Acquire (with)
123import Pantry.Types (PackageNameP (..), VersionP (..), SHA256, FileSize (..), FileType (..), HasPantryConfig, BlobKey, Repo (..), TreeKey, SafeFilePath, Revision (..), Package (..), SnapshotCacheHash (..), connRDBMS)
124import qualified Pantry.SQLite as SQLite
125
126share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
127-- Raw blobs
128Blob
129    sha SHA256
130    size FileSize
131    contents ByteString
132    UniqueBlobSha sha
133-- Previously downloaded blobs from given URLs.
134-- May change over time, so we keep a time column too.
135UrlBlob sql=url_blob
136    url Text
137    blob BlobId
138    time UTCTime
139    UniqueUrlTime url time
140
141-- For normalization, and avoiding storing strings in a bunch of
142-- tables.
143PackageName
144    name P.PackageNameP
145    UniquePackageName name
146Version
147    version P.VersionP
148    UniqueVersion version
149FilePath
150    path P.SafeFilePath
151    UniqueSfp path
152
153-- Secure download information for a package on Hackage. This does not
154-- contain revision information, since sdist tarballs are (blessedly)
155-- unmodified on Hackage.
156HackageTarball
157    name PackageNameId
158    version VersionId
159    sha SHA256
160    size FileSize
161    UniqueHackageTarball name version
162
163-- An individual cabal file from Hackage, representing a specific
164-- revision.
165HackageCabal
166    name PackageNameId
167    version VersionId
168    revision P.Revision
169    cabal BlobId
170
171    -- If available: the full tree containing the HackageTarball
172    -- contents with the cabal file modified.
173    tree TreeId Maybe
174    UniqueHackage name version revision
175
176-- Any preferred-version information from Hackage
177PreferredVersions
178    name PackageNameId
179    preferred Text
180    UniquePreferred name
181
182-- Last time we downloaded a 01-index.tar file from Hackage and
183-- updated the three previous tables.
184CacheUpdate
185    -- When did we do the update?
186    time UTCTime
187
188    -- How big was the file when we updated, ignoring the last two
189    -- all-null 512-byte blocks.
190    size FileSize
191
192    -- SHA256 of the first 'size' bytes of the file
193    sha SHA256
194
195-- A tree containing a Haskell package. See associated TreeEntry
196-- table.
197Tree
198    key BlobId
199
200    -- If the treeCabal field is Nothing, it means the Haskell package
201    -- doesn't have a corresponding cabal file for it. This may be the case
202    -- for haskell package referenced by git repository with only a hpack file.
203    cabal BlobId Maybe
204    cabalType FileType
205    name PackageNameId
206    version VersionId
207    UniqueTree key
208
209HPack
210   tree TreeId
211
212   -- hpack version used for generating this cabal file
213   version VersionId
214
215   -- Generated cabal file for the given tree and hpack version
216   cabalBlob BlobId
217   cabalPath FilePathId
218
219   UniqueHPack tree version
220
221-- An individual file within a Tree.
222TreeEntry
223    tree TreeId
224    path FilePathId
225    blob BlobId
226    type FileType
227
228-- Like UrlBlob, but stores the contents as a Tree.
229ArchiveCache
230    time UTCTime
231    url Text
232    subdir Text
233    sha SHA256
234    size FileSize
235    tree TreeId
236
237-- Like ArchiveCache, but for a Repo.
238RepoCache
239    time UTCTime
240    url Text
241    type P.RepoType
242    commit Text
243    subdir Text
244    tree TreeId
245
246-- Identified by sha of all immutable packages contained in a snapshot
247-- and GHC version used
248SnapshotCache
249    sha SHA256
250    UniqueSnapshotCache sha
251
252PackageExposedModule
253    snapshotCache SnapshotCacheId
254    module ModuleNameId
255    package PackageNameId
256
257ModuleName
258    name P.ModuleNameP
259    UniqueModule name
260|]
261
262initStorage
263  :: HasLogFunc env
264  => Path Abs File -- ^ storage file
265  -> (P.Storage -> RIO env a)
266  -> RIO env a
267initStorage =
268  SQLite.initStorage "Pantry" migrateAll
269
270withStorage
271  :: (HasPantryConfig env, HasLogFunc env)
272  => ReaderT SqlBackend (RIO env) a
273  -> RIO env a
274withStorage action =
275  flip SQLite.withStorage_ action =<< view (P.pantryConfigL.to P.pcStorage)
276
277-- | This is a helper type to distinguish db queries between different rdbms backends. The important
278-- part is that the affects described in this data type should be semantically equivalent between
279-- the supported engines.
280data RdbmsActions env a = RdbmsActions
281  { raSqlite :: !(ReaderT SqlBackend (RIO env) a)
282  -- ^ A query that is specific to SQLite
283  , raPostgres :: !(ReaderT SqlBackend (RIO env) a)
284  -- ^ A query that is specific to PostgreSQL
285  }
286
287-- | This function provides a way to create queries supported by multiple sql backends.
288rdbmsAwareQuery
289  :: RdbmsActions env a
290  -> ReaderT SqlBackend (RIO env) a
291rdbmsAwareQuery RdbmsActions {raSqlite, raPostgres} = do
292  rdbms <- Pantry.Types.connRDBMS <$> ask
293  case rdbms of
294    "postgresql" -> raPostgres
295    "sqlite" -> raSqlite
296    _ -> error $ "rdbmsAwareQuery: unsupported rdbms '" ++ T.unpack rdbms ++ "'"
297
298
299getPackageNameById
300  :: PackageNameId
301  -> ReaderT SqlBackend (RIO env) (Maybe P.PackageName)
302getPackageNameById = fmap (unPackageNameP . packageNameName <$>) . get
303
304
305getPackageNameId
306  :: P.PackageName
307  -> ReaderT SqlBackend (RIO env) PackageNameId
308getPackageNameId = fmap (either entityKey id) . insertBy . PackageName . PackageNameP
309
310getVersionId
311  :: P.Version
312  -> ReaderT SqlBackend (RIO env) VersionId
313getVersionId = fmap (either entityKey id) . insertBy . Version . VersionP
314
315storeBlob
316  :: ByteString
317  -> ReaderT SqlBackend (RIO env) (BlobId, BlobKey)
318storeBlob bs = do
319  let sha = SHA256.hashBytes bs
320      size = FileSize $ fromIntegral $ B.length bs
321  keys <- selectKeysList [BlobSha ==. sha] []
322  key <-
323    case keys of
324      [] ->
325        rdbmsAwareQuery
326          RdbmsActions
327            { raSqlite =
328                insert Blob {blobSha = sha, blobSize = size, blobContents = bs}
329            , raPostgres =
330                do rawExecute
331                     "INSERT INTO blob(sha, size, contents) VALUES (?, ?, ?) ON CONFLICT DO NOTHING"
332                     [ toPersistValue sha
333                     , toPersistValue size
334                     , toPersistValue bs
335                     ]
336                   rawSql
337                     "SELECT blob.id FROM blob WHERE blob.sha = ?"
338                     [toPersistValue sha] >>= \case
339                     [Single key] -> pure key
340                     _ ->
341                       error
342                         "soreBlob: there was a critical problem storing a blob."
343            }
344      key:rest -> assert (null rest) (pure key)
345  pure (key, P.BlobKey sha size)
346
347loadBlob ::
348     HasLogFunc env
349  => BlobKey
350  -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
351loadBlob (P.BlobKey sha size) = do
352  ment <- getBy $ UniqueBlobSha sha
353  case ment of
354    Nothing -> pure Nothing
355    Just (Entity _ bt)
356      | blobSize bt == size -> pure $ Just $ blobContents bt
357      | otherwise ->
358          Nothing <$ lift (logWarn $
359             "Mismatched blob size detected for SHA " <> display sha <>
360             ". Expected size: " <> display size <>
361             ". Actual size: " <> display (blobSize bt))
362
363loadBlobBySHA :: SHA256 -> ReaderT SqlBackend (RIO env) (Maybe BlobId)
364loadBlobBySHA sha = listToMaybe <$> selectKeysList [BlobSha ==. sha] []
365
366loadBlobById :: BlobId -> ReaderT SqlBackend (RIO env) ByteString
367loadBlobById bid = do
368  mbt <- get bid
369  case mbt of
370    Nothing -> error "loadBlobById: ID doesn't exist in database"
371    Just bt -> pure $ blobContents bt
372
373allBlobsSource ::
374     HasResourceMap env
375  => Maybe BlobId
376  -- ^ For some x, yield blob whose id>x.
377  -> ConduitT () (BlobId, ByteString) (ReaderT SqlBackend (RIO env)) ()
378allBlobsSource mblobId =
379  selectSource [BlobId >. blobId | Just blobId <- [mblobId]] [Asc BlobId] .|
380  mapC ((entityKey &&& blobContents . entityVal))
381
382-- | Pull all hackage cabal entries from the database as
383-- 'RawPackageLocationImmutable'. We do a manual join rather than
384-- dropping to raw SQL, and Esqueleto would add more deps.
385allHackageCabalRawPackageLocations ::
386     HasResourceMap env
387  => Maybe HackageCabalId
388  -- ^ For some x, yield cabals whose id>x.
389  -> ReaderT SqlBackend (RIO env) (Map.Map HackageCabalId P.RawPackageLocationImmutable)
390allHackageCabalRawPackageLocations mhackageId = do
391  hackageCabals :: Map HackageCabalId HackageCabal <-
392    selectTuples
393      [HackageCabalId >. hackageId | Just hackageId <- [mhackageId]]
394      []
395  packageNames :: Map PackageNameId PackageName <- selectTuples [] []
396  versions :: Map VersionId Version <- selectTuples [] []
397  for
398    hackageCabals
399    (\hackageCabal ->
400       case Map.lookup (hackageCabalName hackageCabal) packageNames of
401         Nothing -> error "no such package name"
402         Just packageName ->
403           let P.PackageNameP packageName' = packageNameName packageName
404            in case Map.lookup (hackageCabalVersion hackageCabal) versions of
405                 Nothing -> error "no such version"
406                 Just version ->
407                   let P.VersionP version' = versionVersion version
408                    in do mtree <-
409                            case hackageCabalTree hackageCabal of
410                              Just key -> selectFirst [TreeId ==. key] []
411                              Nothing -> pure Nothing
412                          mblobKey <-
413                            maybe
414                              (pure Nothing)
415                              (fmap Just . getBlobKey)
416                              (fmap (treeKey . entityVal) mtree)
417                          pure
418                            (P.RPLIHackage
419                               (P.PackageIdentifierRevision
420                                  packageName'
421                                  version'
422                                  (P.CFIRevision
423                                     (hackageCabalRevision hackageCabal)))
424                               (fmap P.TreeKey mblobKey)))
425  where
426    selectTuples pred sort =
427      fmap (Map.fromList . map tuple) (selectList pred sort)
428    tuple (Entity k v) = (k, v)
429
430allBlobsCount :: Maybe BlobId -> ReaderT SqlBackend (RIO env) Int
431allBlobsCount mblobId = count [BlobId >. blobId | Just blobId <- [mblobId]]
432
433allHackageCabalCount :: Maybe HackageCabalId -> ReaderT SqlBackend (RIO env) Int
434allHackageCabalCount mhackageCabalId =
435  count
436    [ HackageCabalId >. hackageCabalId
437    | Just hackageCabalId <- [mhackageCabalId]
438    ]
439
440getBlobKey :: BlobId -> ReaderT SqlBackend (RIO env) BlobKey
441getBlobKey bid = do
442  res <- rawSql "SELECT sha, size FROM blob WHERE id=?" [toPersistValue bid]
443  case res of
444    [] -> error $ "getBlobKey failed due to missing ID: " ++ show bid
445    [(Single sha, Single size)] -> pure $ P.BlobKey sha size
446    _ -> error $ "getBlobKey failed due to non-unique ID: " ++ show (bid, res)
447
448getBlobId :: BlobKey -> ReaderT SqlBackend (RIO env) (Maybe BlobId)
449getBlobId (P.BlobKey sha size) = do
450  res <- rawSql "SELECT id FROM blob WHERE sha=? AND size=?"
451           [toPersistValue sha, toPersistValue size]
452  pure $ listToMaybe $ map unSingle res
453
454loadURLBlob :: Text -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
455loadURLBlob url = do
456  ment <- rawSql
457    "SELECT blob.contents\n\
458    \FROM blob, url_blob\n\
459    \WHERE url=?\
460    \  AND url_blob.blob=blob.id\n\
461    \ ORDER BY url_blob.time DESC"
462    [toPersistValue url]
463  case ment of
464    [] -> pure Nothing
465    (Single bs) : _ -> pure $ Just bs
466
467storeURLBlob :: Text -> ByteString -> ReaderT SqlBackend (RIO env) ()
468storeURLBlob url blob = do
469  (blobId, _) <- storeBlob blob
470  now <- getCurrentTime
471  insert_ UrlBlob
472        { urlBlobUrl = url
473        , urlBlobBlob = blobId
474        , urlBlobTime = now
475        }
476
477clearHackageRevisions :: ReaderT SqlBackend (RIO env) ()
478clearHackageRevisions = deleteWhere ([] :: [Filter HackageCabal])
479
480storeHackageRevision ::
481     P.PackageName -> P.Version -> BlobId -> ReaderT SqlBackend (RIO env) ()
482storeHackageRevision name version key = do
483  nameid <- getPackageNameId name
484  versionid <- getVersionId version
485  rev <- count
486    [ HackageCabalName ==. nameid
487    , HackageCabalVersion ==. versionid
488    ]
489  insert_ HackageCabal
490    { hackageCabalName = nameid
491    , hackageCabalVersion = versionid
492    , hackageCabalRevision = Revision (fromIntegral rev)
493    , hackageCabalCabal = key
494    , hackageCabalTree = Nothing
495    }
496
497loadHackagePackageVersions
498  :: P.PackageName
499  -> ReaderT SqlBackend (RIO env) (Map P.Version (Map Revision BlobKey))
500loadHackagePackageVersions name = do
501  nameid <- getPackageNameId name
502  -- would be better with esequeleto
503  (Map.fromListWith Map.union . map go) <$> rawSql
504    "SELECT hackage.revision, version.version, blob.sha, blob.size\n\
505    \FROM hackage_cabal as hackage, version, blob\n\
506    \WHERE hackage.name=?\n\
507    \AND   hackage.version=version.id\n\
508    \AND   hackage.cabal=blob.id"
509    [toPersistValue nameid]
510  where
511    go (Single revision, Single (P.VersionP version), Single key, Single size) =
512      (version, Map.singleton revision (P.BlobKey key size))
513
514loadHackagePackageVersion
515  :: P.PackageName
516  -> P.Version
517  -> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, P.BlobKey))
518loadHackagePackageVersion name version = do
519  nameid <- getPackageNameId name
520  versionid <- getVersionId version
521  -- would be better with esequeleto
522  (Map.fromList . map go) <$> rawSql
523    "SELECT hackage.revision, blob.sha, blob.size, blob.id\n\
524    \FROM hackage_cabal as hackage, version, blob\n\
525    \WHERE hackage.name=?\n\
526    \AND   hackage.version=?\n\
527    \AND   hackage.cabal=blob.id"
528    [toPersistValue nameid, toPersistValue versionid]
529  where
530    go (Single revision, Single sha, Single size, Single bid) =
531      (revision, (bid, P.BlobKey sha size))
532
533loadLatestCacheUpdate
534  :: ReaderT SqlBackend (RIO env) (Maybe (FileSize, SHA256))
535loadLatestCacheUpdate =
536    fmap go <$> selectFirst [] [Desc CacheUpdateTime]
537  where
538    go (Entity _ cu) = (cacheUpdateSize cu, cacheUpdateSha cu)
539
540storeCacheUpdate :: FileSize -> SHA256 -> ReaderT SqlBackend (RIO env) ()
541storeCacheUpdate size sha = do
542  now <- getCurrentTime
543  insert_ CacheUpdate
544    { cacheUpdateTime = now
545    , cacheUpdateSize = size
546    , cacheUpdateSha = sha
547    }
548
549storeHackageTarballInfo
550  :: P.PackageName
551  -> P.Version
552  -> SHA256
553  -> FileSize
554  -> ReaderT SqlBackend (RIO env) ()
555storeHackageTarballInfo name version sha size = do
556  nameid <- getPackageNameId name
557  versionid <- getVersionId version
558  void $ insertBy HackageTarball
559    { hackageTarballName = nameid
560    , hackageTarballVersion = versionid
561    , hackageTarballSha = sha
562    , hackageTarballSize = size
563    }
564
565loadHackageTarballInfo
566  :: P.PackageName
567  -> P.Version
568  -> ReaderT SqlBackend (RIO env) (Maybe (SHA256, FileSize))
569loadHackageTarballInfo name version = do
570  nameid <- getPackageNameId name
571  versionid <- getVersionId version
572  fmap go <$> getBy (UniqueHackageTarball nameid versionid)
573  where
574    go (Entity _ ht) = (hackageTarballSha ht, hackageTarballSize ht)
575
576storeCabalFile ::
577       ByteString
578    -> P.PackageName
579    -> ReaderT SqlBackend (RIO env) BlobId
580storeCabalFile cabalBS pkgName = do
581    (bid, _) <- storeBlob cabalBS
582    let cabalFile = P.cabalFileName pkgName
583    _ <- insertBy FilePath {filePathPath = cabalFile}
584    return bid
585
586loadFilePath ::
587       SafeFilePath
588    -> ReaderT SqlBackend (RIO env) (Entity FilePath)
589loadFilePath path = do
590    fp <- getBy $ UniqueSfp path
591    case fp of
592        Nothing ->
593            error $
594            "loadFilePath: No row found for " <>
595            (T.unpack $ P.unSafeFilePath path)
596        Just record -> return record
597
598loadHPackTreeEntity :: TreeId -> ReaderT SqlBackend (RIO env) (Entity TreeEntry)
599loadHPackTreeEntity tid = do
600  filepath <- loadFilePath P.hpackSafeFilePath
601  let filePathId :: FilePathId = entityKey filepath
602  hpackTreeEntry <-
603    selectFirst [TreeEntryTree ==. tid, TreeEntryPath ==. filePathId] []
604  case hpackTreeEntry of
605    Nothing ->
606      error $
607      "loadHPackTreeEntity: No package.yaml file found in TreeEntry for TreeId:  " ++
608      show tid
609    Just record -> return record
610
611storeHPack ::
612       (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
613    => P.RawPackageLocationImmutable
614    -> TreeId
615    -> ReaderT SqlBackend (RIO env) (Key HPack)
616storeHPack rpli tid = do
617    vid <- hpackVersionId
618    hpackRecord <- getBy (UniqueHPack tid vid)
619    case hpackRecord of
620      Nothing -> generateHPack rpli tid vid
621      Just record -> return $ entityKey record
622
623loadCabalBlobKey :: HPackId -> ReaderT SqlBackend (RIO env) BlobKey
624loadCabalBlobKey hpackId = do
625  hpackRecord <- getJust hpackId
626  getBlobKey $ hPackCabalBlob hpackRecord
627
628generateHPack ::
629       (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
630    => P.RawPackageLocationImmutable -- ^ for exceptions
631    -> TreeId
632    -> VersionId
633    -> ReaderT SqlBackend (RIO env) (Key HPack)
634generateHPack rpli tid vid = do
635    tree <- getTree tid
636    (pkgName, cabalBS) <- hpackToCabalS rpli tree
637    bid <- storeCabalFile cabalBS pkgName
638    let cabalFile = P.cabalFileName pkgName
639    fid <- insertBy FilePath {filePathPath = cabalFile}
640    let hpackRecord =
641            HPack
642                { hPackTree = tid
643                , hPackVersion = vid
644                , hPackCabalBlob = bid
645                , hPackCabalPath = either entityKey id fid
646                }
647    either entityKey id <$> insertBy hpackRecord
648
649
650hpackVersionId ::
651       (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
652    => ReaderT SqlBackend (RIO env) VersionId
653hpackVersionId = do
654    hpackSoftwareVersion <- lift hpackVersion
655    fmap (either entityKey id) $
656      insertBy $
657      Version {versionVersion = P.VersionP hpackSoftwareVersion}
658
659
660getFilePathId :: SafeFilePath -> ReaderT SqlBackend (RIO env) FilePathId
661getFilePathId sfp =
662  selectKeysList [FilePathPath ==. sfp] [] >>= \case
663    [fpId] -> pure fpId
664    [] ->
665      rdbmsAwareQuery
666        RdbmsActions
667          { raSqlite = insert $ FilePath sfp
668          , raPostgres =
669              do rawExecute
670                   "INSERT INTO file_path(path) VALUES (?) ON CONFLICT DO NOTHING"
671                   [toPersistValue sfp]
672                 rawSql
673                   "SELECT id FROM file_path WHERE path = ?"
674                   [toPersistValue sfp] >>= \case
675                   [Single key] -> pure key
676                   _ ->
677                     error
678                       "getFilePathId: there was a critical problem storing a blob."
679          }
680    _ ->
681      error $
682      "getFilePathId: FilePath unique constraint key is violated for: " ++ fp
683  where
684    fp = T.unpack (P.unSafeFilePath sfp)
685
686-- | A tree that has already been stored in the database
687newtype CachedTree
688  = CachedTreeMap (Map SafeFilePath (P.TreeEntry, BlobId))
689  deriving Show
690
691unCachedTree :: CachedTree -> P.Tree
692unCachedTree (CachedTreeMap m) = P.TreeMap $ fst <$> m
693
694storeTree
695  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
696  => P.RawPackageLocationImmutable -- ^ for exceptions
697  -> P.PackageIdentifier
698  -> CachedTree
699  -> P.BuildFile
700  -> ReaderT SqlBackend (RIO env) (TreeId, P.TreeKey)
701storeTree rpli (P.PackageIdentifier name version) tree@(CachedTreeMap m) buildFile = do
702  (bid, blobKey) <- storeBlob $ P.renderTree $ unCachedTree tree
703  (cabalid, ftype) <- case buildFile of
704                P.BFHpack (P.TreeEntry _ ftype) -> pure (Nothing, ftype)
705                P.BFCabal _ (P.TreeEntry (P.BlobKey btypeSha _) ftype) -> do
706                               buildTypeid <- loadBlobBySHA btypeSha
707                               buildid <-
708                                   case buildTypeid of
709                                     Just buildId -> pure buildId
710                                     Nothing -> error $ "storeTree: " ++ (show buildFile) ++ " BlobKey not found: " ++ show (tree, btypeSha)
711                               return (Just buildid, ftype)
712  nameid <- getPackageNameId name
713  versionid <- getVersionId version
714  etid <- insertBy Tree
715    { treeKey = bid
716    , treeCabal = cabalid
717    , treeCabalType = ftype
718    , treeName = nameid
719    , treeVersion = versionid
720    }
721
722  (tid, pTreeKey) <- case etid of
723    Left (Entity tid _) -> pure (tid, P.TreeKey blobKey) -- already in database, assume it matches
724    Right tid -> do
725      for_ (Map.toList m) $ \(sfp, (P.TreeEntry _blobKey ft, bid')) -> do
726        sfpid <- getFilePathId sfp
727        insert_ TreeEntry
728          { treeEntryTree = tid
729          , treeEntryPath = sfpid
730          , treeEntryBlob = bid'
731          , treeEntryType = ft
732          }
733      pure (tid, P.TreeKey blobKey)
734  case buildFile of
735    P.BFHpack _ -> storeHPack rpli tid >> return ()
736    P.BFCabal _ _ -> return ()
737  return (tid, pTreeKey)
738
739getTree :: TreeId -> ReaderT SqlBackend (RIO env) P.Tree
740getTree tid = do
741  (mts :: Maybe Tree) <- get tid
742  ts <-
743      case mts of
744        Nothing ->
745            error $ "getTree: invalid foreign key " ++ show tid
746        Just ts -> pure ts
747  loadTreeByEnt $ Entity tid ts
748
749loadTree :: P.TreeKey -> ReaderT SqlBackend (RIO env) (Maybe P.Tree)
750loadTree key = do
751  ment <- getTreeForKey key
752  case ment of
753    Nothing -> pure Nothing
754    Just ent -> Just <$> loadTreeByEnt ent
755
756getTreeForKey
757  :: TreeKey
758  -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
759getTreeForKey (P.TreeKey key) = do
760  mbid <- getBlobId key
761  case mbid of
762    Nothing -> pure Nothing
763    Just bid -> getBy $ UniqueTree bid
764
765loadPackageById ::
766       (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
767    => P.RawPackageLocationImmutable -- ^ for exceptions
768    -> TreeId
769    -> ReaderT SqlBackend (RIO env) Package
770loadPackageById rpli tid = do
771    (mts :: Maybe Tree) <- get tid
772    ts <-
773        case mts of
774            Nothing ->
775                error $ "loadPackageById: invalid foreign key " ++ show tid
776            Just ts -> pure ts
777    (tree :: P.Tree) <- loadTreeByEnt $ Entity tid ts
778    (blobKey :: BlobKey) <- getBlobKey $ treeKey ts
779    (mname :: Maybe PackageName) <- get $ treeName ts
780    name <-
781        case mname of
782            Nothing ->
783                error $
784                "loadPackageByid: invalid foreign key " ++ show (treeName ts)
785            Just (PackageName (P.PackageNameP name)) -> pure name
786    mversion <- get $ treeVersion ts
787    version <-
788        case mversion of
789            Nothing ->
790                error $
791                "loadPackageByid: invalid foreign key " ++ show (treeVersion ts)
792            Just (Version (P.VersionP version)) -> pure version
793    let ident = P.PackageIdentifier name version
794    (packageEntry, mtree) <-
795        case treeCabal ts of
796            Just keyBlob -> do
797                cabalKey <- getBlobKey keyBlob
798                return
799                    ( P.PCCabalFile $ P.TreeEntry cabalKey (treeCabalType ts)
800                    , tree)
801            Nothing -> do
802                hpackVid <- hpackVersionId
803                hpackEntity <- getBy (UniqueHPack tid hpackVid)
804                let (P.TreeMap tmap) = tree
805                    cabalFile = P.cabalFileName name
806                case hpackEntity of
807                    Nothing
808                        -- This case will happen when you either
809                        -- update stack with a new hpack version or
810                        -- use different hpack version via
811                        -- --with-hpack option.
812                     -> do
813                        (hpackId :: HPackId) <- storeHPack rpli tid
814                        hpackRecord <- getJust hpackId
815                        getHPackCabalFile hpackRecord ts tmap cabalFile
816                    Just (Entity _ item) ->
817                        getHPackCabalFile item ts tmap cabalFile
818    pure
819        Package
820            { packageTreeKey = P.TreeKey blobKey
821            , packageTree = mtree
822            , packageCabalEntry = packageEntry
823            , packageIdent = ident
824            }
825
826getHPackBlobKey :: HPack -> ReaderT SqlBackend (RIO env) BlobKey
827getHPackBlobKey hpackRecord = do
828  let treeId = hPackTree hpackRecord
829  hpackEntity <- loadHPackTreeEntity treeId
830  getBlobKey (treeEntryBlob $ entityVal hpackEntity)
831
832getHPackBlobKeyById :: HPackId -> ReaderT SqlBackend (RIO env) BlobKey
833getHPackBlobKeyById hpackId = do
834  hpackRecord <- getJust hpackId
835  getHPackBlobKey hpackRecord
836
837
838getHPackCabalFile ::
839       (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
840    => HPack
841    -> Tree
842    -> Map SafeFilePath P.TreeEntry
843    -> SafeFilePath
844    -> ReaderT SqlBackend (RIO env) (P.PackageCabal, P.Tree)
845getHPackCabalFile hpackRecord ts tmap cabalFile = do
846    cabalKey <- getBlobKey (hPackCabalBlob hpackRecord)
847    hpackKey <- getHPackBlobKey hpackRecord
848    hpackSoftwareVersion <- lift hpackVersion
849    let fileType = treeCabalType ts
850        cbTreeEntry = P.TreeEntry cabalKey fileType
851        hpackTreeEntry = P.TreeEntry hpackKey fileType
852        tree = P.TreeMap $ Map.insert cabalFile cbTreeEntry tmap
853    return
854        ( P.PCHpack $
855          P.PHpack
856              { P.phOriginal = hpackTreeEntry
857              , P.phGenerated = cbTreeEntry
858              , P.phVersion = hpackSoftwareVersion
859              }
860        , tree)
861
862loadTreeByEnt :: Entity Tree -> ReaderT SqlBackend (RIO env) P.Tree
863loadTreeByEnt (Entity tid _t) = do
864  entries <- rawSql
865    "SELECT file_path.path, blob.sha, blob.size, tree_entry.type\n\
866    \FROM tree_entry, blob, file_path\n\
867    \WHERE tree_entry.tree=?\n\
868    \AND   tree_entry.blob=blob.id\n\
869    \AND   tree_entry.path=file_path.id"
870    [toPersistValue tid]
871  pure $ P.TreeMap $ Map.fromList $ map
872    (\(Single sfp, Single sha, Single size, Single ft) ->
873         (sfp, P.TreeEntry (P.BlobKey sha size) ft))
874    entries
875
876storeHackageTree
877  :: P.PackageName
878  -> P.Version
879  -> BlobId
880  -> P.TreeKey
881  -> ReaderT SqlBackend (RIO env) ()
882storeHackageTree name version cabal treeKey' = do
883  nameid <- getPackageNameId name
884  versionid <- getVersionId version
885  ment <- getTreeForKey treeKey'
886  for_ ment $ \ent -> updateWhere
887    [ HackageCabalName ==. nameid
888    , HackageCabalVersion ==. versionid
889    , HackageCabalCabal ==. cabal
890    ]
891    [HackageCabalTree =. Just (entityKey ent)]
892
893loadHackageTreeKey
894  :: P.PackageName
895  -> P.Version
896  -> SHA256
897  -> ReaderT SqlBackend (RIO env) (Maybe TreeKey)
898loadHackageTreeKey name ver sha = do
899  res <- rawSql
900    "SELECT treeblob.sha, treeblob.size\n\
901    \FROM blob as treeblob, blob as cabalblob, package_name, version, hackage_cabal, tree\n\
902    \WHERE package_name.name=?\n\
903    \AND   version.version=?\n\
904    \AND   cabalblob.sha=?\n\
905    \AND   hackage_cabal.name=package_name.id\n\
906    \AND   hackage_cabal.version=version.id\n\
907    \AND   hackage_cabal.cabal=cabalblob.id\n\
908    \AND   hackage_cabal.tree=tree.id\n\
909    \AND   tree.key=treeblob.id"
910    [ toPersistValue $ P.PackageNameP name
911    , toPersistValue $ P.VersionP ver
912    , toPersistValue sha
913    ]
914  case res of
915    [] -> pure Nothing
916    (Single treesha, Single size):_ ->
917      pure $ Just $ P.TreeKey $ P.BlobKey treesha size
918
919loadHackageTree
920  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
921  => P.RawPackageLocationImmutable -- ^ for exceptions
922  -> P.PackageName
923  -> P.Version
924  -> BlobId
925  -> ReaderT SqlBackend (RIO env) (Maybe Package)
926loadHackageTree rpli name ver bid = do
927  nameid <- getPackageNameId name
928  versionid <- getVersionId ver
929  ment <- selectFirst
930    [ HackageCabalName ==. nameid
931    , HackageCabalVersion ==. versionid
932    , HackageCabalCabal ==. bid
933    , HackageCabalTree !=. Nothing
934    ]
935    []
936  case ment of
937    Nothing -> pure Nothing
938    Just (Entity _ hc) ->
939      case hackageCabalTree hc of
940        Nothing -> assert False $ pure Nothing
941        Just tid -> Just <$> loadPackageById rpli tid
942
943storeArchiveCache
944  :: Text -- ^ URL
945  -> Text -- ^ subdir
946  -> SHA256
947  -> FileSize
948  -> P.TreeKey
949  -> ReaderT SqlBackend (RIO env) ()
950storeArchiveCache url subdir sha size treeKey' = do
951  now <- getCurrentTime
952  ment <- getTreeForKey treeKey'
953  for_ ment $ \ent -> insert_ ArchiveCache
954    { archiveCacheTime = now
955    , archiveCacheUrl = url
956    , archiveCacheSubdir = subdir
957    , archiveCacheSha = sha
958    , archiveCacheSize = size
959    , archiveCacheTree = entityKey ent
960    }
961
962loadArchiveCache
963  :: Text -- ^ URL
964  -> Text -- ^ subdir
965  -> ReaderT SqlBackend (RIO env) [(SHA256, FileSize, TreeId)]
966loadArchiveCache url subdir = map go <$> selectList
967  [ ArchiveCacheUrl ==. url
968  , ArchiveCacheSubdir ==. subdir
969  ]
970  [Desc ArchiveCacheTime]
971  where
972    go (Entity _ ac) = (archiveCacheSha ac, archiveCacheSize ac, archiveCacheTree ac)
973
974storeRepoCache
975  :: Repo
976  -> Text -- ^ subdir
977  -> TreeId
978  -> ReaderT SqlBackend (RIO env) ()
979storeRepoCache repo subdir tid = do
980  now <- getCurrentTime
981  insert_ RepoCache
982    { repoCacheTime = now
983    , repoCacheUrl = repoUrl repo
984    , repoCacheType = repoType repo
985    , repoCacheCommit = repoCommit repo
986    , repoCacheSubdir = subdir
987    , repoCacheTree = tid
988    }
989
990loadRepoCache
991  :: Repo
992  -> Text -- ^ subdir
993  -> ReaderT SqlBackend (RIO env) (Maybe TreeId)
994loadRepoCache repo subdir = fmap (repoCacheTree . entityVal) <$> selectFirst
995  [ RepoCacheUrl ==. repoUrl repo
996  , RepoCacheType ==. repoType repo
997  , RepoCacheCommit ==. repoCommit repo
998  , RepoCacheSubdir ==. subdir
999  ]
1000  [Desc RepoCacheTime]
1001
1002storePreferredVersion ::
1003     P.PackageName -> Text -> ReaderT SqlBackend (RIO env) ()
1004storePreferredVersion name p = do
1005  nameid <- getPackageNameId name
1006  ment <- getBy $ UniquePreferred nameid
1007  case ment of
1008    Nothing -> insert_ PreferredVersions
1009      { preferredVersionsName = nameid
1010      , preferredVersionsPreferred = p
1011      }
1012    Just (Entity pid _) -> update pid [PreferredVersionsPreferred =. p]
1013
1014loadPreferredVersion ::
1015     P.PackageName -> ReaderT SqlBackend (RIO env) (Maybe Text)
1016loadPreferredVersion name = do
1017  nameid <- getPackageNameId name
1018  fmap (preferredVersionsPreferred . entityVal) <$> getBy (UniquePreferred nameid)
1019
1020sinkHackagePackageNames
1021  :: (P.PackageName -> Bool)
1022  -> ConduitT P.PackageName Void (ReaderT SqlBackend (RIO env)) a
1023  -> ReaderT SqlBackend (RIO env) a
1024sinkHackagePackageNames predicate sink = do
1025  acqSrc <- selectSourceRes [] []
1026  with acqSrc $ \src -> runConduit
1027    $ src
1028   .| concatMapMC go
1029   .| sink
1030  where
1031    go (Entity nameid (PackageName (PackageNameP name)))
1032      | predicate name = do
1033          -- Make sure it's actually on Hackage. Would be much more
1034          -- efficient with some raw SQL and an inner join, but we
1035          -- don't have a Conduit version of rawSql.
1036          onHackage <- checkOnHackage nameid
1037          pure $ if onHackage then Just name else Nothing
1038      | otherwise = pure Nothing
1039
1040    checkOnHackage nameid = do
1041      cnt <- count [HackageCabalName ==. nameid]
1042      pure $ cnt > 0
1043
1044-- | Get the filename for the cabal file in the given directory.
1045--
1046-- If no .cabal file is present, or more than one is present, an exception is
1047-- thrown via 'throwM'.
1048--
1049-- If the directory contains a file named package.yaml, hpack is used to
1050-- generate a .cabal file from it.
1051findOrGenerateCabalFile
1052    :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
1053    => Path Abs Dir -- ^ package directory
1054    -> RIO env (P.PackageName, Path Abs File)
1055findOrGenerateCabalFile pkgDir = do
1056    hpack pkgDir
1057    files <- filter (flip hasExtension "cabal" . toFilePath) . snd
1058         <$> listDir pkgDir
1059    -- If there are multiple files, ignore files that start with
1060    -- ".". On unixlike environments these are hidden, and this
1061    -- character is not valid in package names. The main goal is
1062    -- to ignore emacs lock files - see
1063    -- https://github.com/commercialhaskell/stack/issues/1897.
1064    let isHidden ('.':_) = True
1065        isHidden _ = False
1066    case filter (not . isHidden . fromRelFile . filename) files of
1067        [] -> throwIO $ P.NoCabalFileFound pkgDir
1068        [x] -> maybe
1069          (throwIO $ P.InvalidCabalFilePath x)
1070          (\pn -> pure $ (pn, x)) $
1071            List.stripSuffix ".cabal" (toFilePath (filename x)) >>=
1072            P.parsePackageName
1073        _:_ -> throwIO $ P.MultipleCabalFilesFound pkgDir files
1074      where hasExtension fp x = FilePath.takeExtension fp == "." ++ x
1075
1076-- | Similar to 'hpackToCabal' but doesn't require a new connection to database.
1077hpackToCabalS :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
1078              => P.RawPackageLocationImmutable -- ^ for exceptions
1079              -> P.Tree
1080              -> ReaderT SqlBackend (RIO env) (P.PackageName, ByteString)
1081hpackToCabalS rpli tree = do
1082  tmpDir <- lift $ do
1083              tdir <- getTempDir
1084              createTempDir tdir "hpack-pkg-dir"
1085  unpackTreeToDir rpli tmpDir tree
1086  (packageName, cfile) <- lift $ findOrGenerateCabalFile tmpDir
1087  !bs <- lift $ B.readFile (fromAbsFile cfile)
1088  lift $ removeDirRecur tmpDir
1089  return $ (packageName, bs)
1090
1091hpackToCabal :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
1092           => P.RawPackageLocationImmutable -- ^ for exceptions
1093           -> P.Tree
1094           -> RIO env (P.PackageName, ByteString)
1095hpackToCabal rpli tree = withSystemTempDirectory "hpack-pkg-dir" $ \tmpdir -> do
1096               tdir <- parseAbsDir tmpdir
1097               withStorage $ unpackTreeToDir rpli tdir tree
1098               (packageName, cfile) <- findOrGenerateCabalFile tdir
1099               bs <- B.readFile (fromAbsFile cfile)
1100               return (packageName, bs)
1101
1102unpackTreeToDir
1103  :: (HasPantryConfig env, HasLogFunc env)
1104  => P.RawPackageLocationImmutable -- ^ for exceptions
1105  -> Path Abs Dir -- ^ dest dir, will be created if necessary
1106  -> P.Tree
1107  -> ReaderT SqlBackend (RIO env) ()
1108unpackTreeToDir rpli (toFilePath -> dir) (P.TreeMap m) = do
1109  for_  (Map.toList m) $ \(sfp, P.TreeEntry blobKey ft) -> do
1110    let dest = dir </> T.unpack (P.unSafeFilePath sfp)
1111    createDirectoryIfMissing True $ takeDirectory dest
1112    mbs <- loadBlob blobKey
1113    case mbs of
1114      Nothing -> do
1115        -- TODO when we have pantry wire stuff, try downloading
1116        throwIO $ P.TreeReferencesMissingBlob rpli sfp blobKey
1117      Just bs -> do
1118        B.writeFile dest bs
1119        case ft of
1120          FTNormal -> pure ()
1121          FTExecutable -> liftIO $ do
1122            perms <- getPermissions dest
1123            setPermissions dest $ setOwnerExecutable True perms
1124
1125countHackageCabals :: ReaderT SqlBackend (RIO env) Int
1126countHackageCabals = do
1127  res <- rawSql
1128    "SELECT COUNT(*)\n\
1129    \FROM hackage_cabal"
1130    []
1131  case res of
1132    [] -> pure 0
1133    (Single n):_ ->
1134      pure n
1135
1136getSnapshotCacheByHash
1137  :: SnapshotCacheHash
1138  -> ReaderT SqlBackend (RIO env) (Maybe SnapshotCacheId)
1139getSnapshotCacheByHash =
1140  fmap (fmap entityKey) . getBy . UniqueSnapshotCache . unSnapshotCacheHash
1141
1142getSnapshotCacheId
1143  :: SnapshotCacheHash
1144  -> ReaderT SqlBackend (RIO env) SnapshotCacheId
1145getSnapshotCacheId =
1146  fmap (either entityKey id) . insertBy . SnapshotCache . unSnapshotCacheHash
1147
1148getModuleNameId
1149  :: P.ModuleName
1150  -> ReaderT SqlBackend (RIO env) ModuleNameId
1151getModuleNameId =
1152  fmap (either entityKey id) . insertBy . ModuleName . P.ModuleNameP
1153
1154storeSnapshotModuleCache
1155  :: SnapshotCacheId
1156  -> Map P.PackageName (Set P.ModuleName)
1157  -> ReaderT SqlBackend (RIO env) ()
1158storeSnapshotModuleCache cache packageModules =
1159  forM_ (Map.toList packageModules) $ \(pn, modules) -> do
1160    package <- getPackageNameId pn
1161    forM_ modules $ \m -> do
1162      moduleName <- getModuleNameId m
1163      insert_ PackageExposedModule
1164        { packageExposedModuleSnapshotCache = cache
1165        , packageExposedModulePackage = package
1166        , packageExposedModuleModule = moduleName
1167        }
1168
1169loadExposedModulePackages
1170  :: SnapshotCacheId
1171  -> P.ModuleName
1172  -> ReaderT SqlBackend (RIO env) [P.PackageName]
1173loadExposedModulePackages cacheId mName =
1174  map go <$> rawSql
1175    "SELECT package_name.name\n\
1176    \FROM package_name, package_exposed_module, module_name\n\
1177    \WHERE module_name.name=?\n\
1178    \AND   package_exposed_module.snapshot_cache=?\n\
1179    \AND   module_name.id=package_exposed_module.module\n\
1180    \AND   package_name.id=package_exposed_module.package"
1181    [ toPersistValue (P.ModuleNameP mName)
1182    , toPersistValue cacheId
1183    ]
1184  where
1185    go (Single (P.PackageNameP m)) = m
1186
1187data LoadCachedTreeException = MissingBlob !BlobKey
1188  deriving (Show, Typeable)
1189instance Exception LoadCachedTreeException
1190
1191-- | Ensure that all blobs needed for this package are present in the cache
1192loadCachedTree :: forall env. P.Tree -> ReaderT SqlBackend (RIO env) (Either LoadCachedTreeException CachedTree)
1193loadCachedTree (P.TreeMap m) =
1194    try $ CachedTreeMap <$> traverse loadEntry m
1195  where
1196    loadEntry :: P.TreeEntry -> ReaderT SqlBackend (RIO env) (P.TreeEntry, BlobId)
1197    loadEntry te = (te, ) <$> loadBlob' (P.teBlob te)
1198
1199    loadBlob' :: BlobKey -> ReaderT SqlBackend (RIO env) BlobId
1200    loadBlob' blobKey@(P.BlobKey sha _) = do
1201      mbid <- loadBlobBySHA sha
1202      case mbid of
1203        Nothing -> throwIO $ MissingBlob blobKey
1204        Just bid -> pure bid
1205