{-# 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
import           Data.Acquire ( with )
import           Database.Persist
import           Database.Persist.Sqlite
import           Database.Persist.TH
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
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 :: forall env a.
HasLogFunc env =>
Path Abs File -> (Storage -> RIO env a) -> RIO env a
initStorage =
  forall env a.
HasLogFunc env =>
Text
-> Migration
-> Path Abs File
-> (Storage -> RIO env a)
-> RIO env a
SQLite.initStorage Text
"Pantry" Migration
migrateAll

withStorage ::
     (HasPantryConfig env, HasLogFunc env)
  => ReaderT SqlBackend (RIO env) a
  -> RIO env a
withStorage :: forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage ReaderT SqlBackend (RIO env) a
action = do
  Storage
storage <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall env. HasPantryConfig env => Lens' env PantryConfig
P.pantryConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig -> Storage
P.pcStorage)
  Storage
-> forall env a.
   HasLogFunc env =>
   ReaderT SqlBackend (RIO env) a -> RIO env a
SQLite.withStorage_ Storage
storage ReaderT SqlBackend (RIO env) a
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
  { forall env a. RdbmsActions env a -> ReaderT SqlBackend (RIO env) a
raSqlite :: !(ReaderT SqlBackend (RIO env) a)
  -- ^ A query that is specific to SQLite

  , forall env a. RdbmsActions env a -> ReaderT SqlBackend (RIO env) a
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 :: forall env a. RdbmsActions env a -> ReaderT SqlBackend (RIO env) a
rdbmsAwareQuery RdbmsActions {ReaderT SqlBackend (RIO env) a
raSqlite :: ReaderT SqlBackend (RIO env) a
raSqlite :: forall env a. RdbmsActions env a -> ReaderT SqlBackend (RIO env) a
raSqlite, ReaderT SqlBackend (RIO env) a
raPostgres :: ReaderT SqlBackend (RIO env) a
raPostgres :: forall env a. RdbmsActions env a -> ReaderT SqlBackend (RIO env) a
raPostgres} = do
  Text
rdbms <- SqlBackend -> Text
Pantry.Types.connRDBMS forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
  case Text
rdbms of
    Text
"postgresql" -> ReaderT SqlBackend (RIO env) a
raPostgres
    Text
"sqlite" -> ReaderT SqlBackend (RIO env) a
raSqlite
    Text
_ -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"rdbmsAwareQuery: unsupported rdbms '" forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
rdbms forall a. [a] -> [a] -> [a]
++ String
"'"

getPackageNameById ::
     PackageNameId
  -> ReaderT SqlBackend (RIO env) (Maybe P.PackageName)
getPackageNameById :: forall env.
Key PackageName -> ReaderT SqlBackend (RIO env) (Maybe PackageName)
getPackageNameById = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PackageNameP -> PackageName
unPackageNameP forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> PackageNameP
packageNameName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall backend record (m :: * -> *).
(PersistStoreRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
get

getPackageNameId ::
     P.PackageName
  -> ReaderT SqlBackend (RIO env) PackageNameId
getPackageNameId :: forall env.
PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
getPackageNameId =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall record. Entity record -> Key record
entityKey forall a. a -> a
id) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall record backend (m :: * -> *).
(MonadIO m, PersistUniqueWrite backend,
 PersistRecordBackend record backend, AtLeastOneUniqueKey record,
 SafeToInsert record) =>
record -> ReaderT backend m (Either (Entity record) (Key record))
insertBy forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageNameP -> PackageName
PackageName forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> PackageNameP
PackageNameP

getVersionId ::
     P.Version
  -> ReaderT SqlBackend (RIO env) VersionId
getVersionId :: forall env. Version -> ReaderT SqlBackend (RIO env) (Key Version)
getVersionId = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall record. Entity record -> Key record
entityKey forall a. a -> a
id) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall record backend (m :: * -> *).
(MonadIO m, PersistUniqueWrite backend,
 PersistRecordBackend record backend, AtLeastOneUniqueKey record,
 SafeToInsert record) =>
record -> ReaderT backend m (Either (Entity record) (Key record))
insertBy forall b c a. (b -> c) -> (a -> b) -> a -> c
. VersionP -> Version
Version forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> VersionP
VersionP

storeBlob ::
     ByteString
  -> ReaderT SqlBackend (RIO env) (BlobId, BlobKey)
storeBlob :: forall env.
ByteString -> ReaderT SqlBackend (RIO env) (Key Blob, BlobKey)
storeBlob ByteString
bs = do
  let sha :: SHA256
sha = ByteString -> SHA256
SHA256.hashBytes ByteString
bs
      size :: FileSize
size = Word -> FileSize
FileSize forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length ByteString
bs
  [Key Blob]
keys <- forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Key record]
selectKeysList [forall typ. (typ ~ SHA256) => EntityField Blob typ
BlobSha forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. SHA256
sha] []
  Key Blob
key <-
    case [Key Blob]
keys of
      [] ->
        forall env a. RdbmsActions env a -> ReaderT SqlBackend (RIO env) a
rdbmsAwareQuery
          RdbmsActions
            { raSqlite :: ReaderT SqlBackend (RIO env) (Key Blob)
raSqlite =
                forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m (Key record)
insert Blob {blobSha :: SHA256
blobSha = SHA256
sha, blobSize :: FileSize
blobSize = FileSize
size, blobContents :: ByteString
blobContents = ByteString
bs}
            , raPostgres :: ReaderT SqlBackend (RIO env) (Key Blob)
raPostgres = do
                forall (m :: * -> *) backend.
(MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m ()
rawExecute
                  Text
"INSERT INTO blob(sha, size, contents) VALUES (?, ?, ?) ON \
                  \CONFLICT DO NOTHING"
                  [ forall a. PersistField a => a -> PersistValue
toPersistValue SHA256
sha
                  , forall a. PersistField a => a -> PersistValue
toPersistValue FileSize
size
                  , forall a. PersistField a => a -> PersistValue
toPersistValue ByteString
bs
                  ]
                forall a (m :: * -> *) backend.
(RawSql a, MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m [a]
rawSql
                  Text
"SELECT blob.id FROM blob WHERE blob.sha = ?"
                  [forall a. PersistField a => a -> PersistValue
toPersistValue SHA256
sha] forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  [Single Key Blob
key] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Key Blob
key
                  [Single (Key Blob)]
_ -> forall a. HasCallStack => String -> a
error
                    String
"soreBlob: there was a critical problem storing a blob."
            }
      Key Blob
key:[Key Blob]
rest -> forall a. HasCallStack => Bool -> a -> a
assert (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Key Blob]
rest) (forall (f :: * -> *) a. Applicative f => a -> f a
pure Key Blob
key)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Key Blob
key, SHA256 -> FileSize -> BlobKey
P.BlobKey SHA256
sha FileSize
size)

loadBlob ::
     HasLogFunc env
  => BlobKey
  -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
loadBlob :: forall env.
HasLogFunc env =>
BlobKey -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
loadBlob (P.BlobKey SHA256
sha FileSize
size) = do
  Maybe (Entity Blob)
ment <- forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
getBy forall a b. (a -> b) -> a -> b
$ SHA256 -> Unique Blob
UniqueBlobSha SHA256
sha
  case Maybe (Entity Blob)
ment of
    Maybe (Entity Blob)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    Just (Entity Key Blob
_ Blob
bt)
      | Blob -> FileSize
blobSize Blob
bt forall a. Eq a => a -> a -> Bool
== FileSize
size -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Blob -> ByteString
blobContents Blob
bt
      | Bool
otherwise ->
          forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$
             Utf8Builder
"Mismatched blob size detected for SHA " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display SHA256
sha forall a. Semigroup a => a -> a -> a
<>
             Utf8Builder
". Expected size: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display FileSize
size forall a. Semigroup a => a -> a -> a
<>
             Utf8Builder
". Actual size: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (Blob -> FileSize
blobSize Blob
bt))

loadBlobBySHA :: SHA256 -> ReaderT SqlBackend (RIO env) (Maybe BlobId)
loadBlobBySHA :: forall env.
SHA256 -> ReaderT SqlBackend (RIO env) (Maybe (Key Blob))
loadBlobBySHA SHA256
sha = forall a. [a] -> Maybe a
listToMaybe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Key record]
selectKeysList [forall typ. (typ ~ SHA256) => EntityField Blob typ
BlobSha forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. SHA256
sha] []

loadBlobById :: BlobId -> ReaderT SqlBackend (RIO env) ByteString
loadBlobById :: forall env. Key Blob -> ReaderT SqlBackend (RIO env) ByteString
loadBlobById Key Blob
bid = do
  Maybe Blob
mbt <- forall backend record (m :: * -> *).
(PersistStoreRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
get Key Blob
bid
  case Maybe Blob
mbt of
    Maybe Blob
Nothing -> forall a. HasCallStack => String -> a
error String
"loadBlobById: ID doesn't exist in database"
    Just Blob
bt -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Blob -> ByteString
blobContents Blob
bt

allBlobsSource ::
     HasResourceMap env
  => Maybe BlobId
  -- ^ For some x, yield blob whose id>x.

  -> ConduitT () (BlobId, ByteString) (ReaderT SqlBackend (RIO env)) ()
allBlobsSource :: forall env.
HasResourceMap env =>
Maybe (Key Blob)
-> ConduitT
     () (Key Blob, ByteString) (ReaderT SqlBackend (RIO env)) ()
allBlobsSource Maybe (Key Blob)
mblobId =
  forall record backend (m :: * -> *).
(PersistQueryRead backend, MonadResource m,
 PersistRecordBackend record backend, MonadReader backend m) =>
[Filter record]
-> [SelectOpt record] -> ConduitM () (Entity record) m ()
selectSource [forall typ. (typ ~ Key Blob) => EntityField Blob typ
BlobId forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
>. Key Blob
blobId | Just Key Blob
blobId <- [Maybe (Key Blob)
mblobId]] [forall record typ. EntityField record typ -> SelectOpt record
Asc forall typ. (typ ~ Key Blob) => EntityField Blob typ
BlobId] forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.|
  forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
mapC (forall record. Entity record -> Key record
entityKey forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Blob -> ByteString
blobContents forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall record. Entity record -> record
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 :: forall env.
HasResourceMap env =>
Maybe (Key HackageCabal)
-> ReaderT
     SqlBackend
     (RIO env)
     (Map (Key HackageCabal) RawPackageLocationImmutable)
allHackageCabalRawPackageLocations Maybe (Key HackageCabal)
mhackageId = do
  Map (Key HackageCabal) HackageCabal
hackageCabals :: Map HackageCabalId HackageCabal <-
    forall {a} {backend} {m :: * -> *}.
(PersistEntityBackend a ~ BaseBackend backend,
 PersistQueryRead backend, MonadIO m, PersistEntity a) =>
[Filter a] -> [SelectOpt a] -> ReaderT backend m (Map (Key a) a)
selectTuples
      [forall typ.
(typ ~ Key HackageCabal) =>
EntityField HackageCabal typ
HackageCabalId forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
>. Key HackageCabal
hackageId | Just Key HackageCabal
hackageId <- [Maybe (Key HackageCabal)
mhackageId]]
      []
  Map (Key PackageName) PackageName
packageNames :: Map PackageNameId PackageName <- forall {a} {backend} {m :: * -> *}.
(PersistEntityBackend a ~ BaseBackend backend,
 PersistQueryRead backend, MonadIO m, PersistEntity a) =>
[Filter a] -> [SelectOpt a] -> ReaderT backend m (Map (Key a) a)
selectTuples [] []
  Map (Key Version) Version
versions :: Map VersionId Version <- forall {a} {backend} {m :: * -> *}.
(PersistEntityBackend a ~ BaseBackend backend,
 PersistQueryRead backend, MonadIO m, PersistEntity a) =>
[Filter a] -> [SelectOpt a] -> ReaderT backend m (Map (Key a) a)
selectTuples [] []
  forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for
    Map (Key HackageCabal) HackageCabal
hackageCabals
    (\HackageCabal
hackageCabal ->
       case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (HackageCabal -> Key PackageName
hackageCabalName HackageCabal
hackageCabal) Map (Key PackageName) PackageName
packageNames of
         Maybe PackageName
Nothing -> forall a. HasCallStack => String -> a
error String
"no such package name"
         Just PackageName
packageName ->
           let P.PackageNameP PackageName
packageName' = PackageName -> PackageNameP
packageNameName PackageName
packageName
            in case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (HackageCabal -> Key Version
hackageCabalVersion HackageCabal
hackageCabal) Map (Key Version) Version
versions of
                 Maybe Version
Nothing -> forall a. HasCallStack => String -> a
error String
"no such version"
                 Just Version
version ->
                   let P.VersionP Version
version' = Version -> VersionP
versionVersion Version
version
                    in do Maybe (Entity Tree)
mtree <-
                            case HackageCabal -> Maybe (Key Tree)
hackageCabalTree HackageCabal
hackageCabal of
                              Just Key Tree
key -> forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m (Maybe (Entity record))
selectFirst [forall typ. (typ ~ Key Tree) => EntityField Tree typ
TreeId forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key Tree
key] []
                              Maybe (Key Tree)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
                          Maybe BlobKey
mblobKey <-
                            forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                              (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing)
                              ((forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall env. Key Blob -> ReaderT SqlBackend (RIO env) BlobKey
getBlobKey) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree -> Key Blob
treeKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall record. Entity record -> record
entityVal)
                              Maybe (Entity Tree)
mtree
                          forall (f :: * -> *) a. Applicative f => a -> f a
pure
                            (PackageIdentifierRevision
-> Maybe TreeKey -> RawPackageLocationImmutable
P.RPLIHackage
                               (PackageName
-> Version -> CabalFileInfo -> PackageIdentifierRevision
P.PackageIdentifierRevision
                                  PackageName
packageName'
                                  Version
version'
                                  (Revision -> CabalFileInfo
P.CFIRevision
                                     (HackageCabal -> Revision
hackageCabalRevision HackageCabal
hackageCabal)))
                               (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BlobKey -> TreeKey
P.TreeKey Maybe BlobKey
mblobKey)))
 where
  selectTuples :: [Filter a] -> [SelectOpt a] -> ReaderT backend m (Map (Key a) a)
selectTuples [Filter a]
pred [SelectOpt a]
sort =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {b}. Entity b -> (Key b, b)
tuple) (forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Entity record]
selectList [Filter a]
pred [SelectOpt a]
sort)
  tuple :: Entity b -> (Key b, b)
tuple (Entity Key b
k b
v) = (Key b
k, b
v)

allBlobsCount :: Maybe BlobId -> ReaderT SqlBackend (RIO env) Int
allBlobsCount :: forall env. Maybe (Key Blob) -> ReaderT SqlBackend (RIO env) Int
allBlobsCount Maybe (Key Blob)
mblobId = forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m Int
count [forall typ. (typ ~ Key Blob) => EntityField Blob typ
BlobId forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
>. Key Blob
blobId | Just Key Blob
blobId <- [Maybe (Key Blob)
mblobId]]

allHackageCabalCount :: Maybe HackageCabalId -> ReaderT SqlBackend (RIO env) Int
allHackageCabalCount :: forall env.
Maybe (Key HackageCabal) -> ReaderT SqlBackend (RIO env) Int
allHackageCabalCount Maybe (Key HackageCabal)
mhackageCabalId =
  forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m Int
count
    [ forall typ.
(typ ~ Key HackageCabal) =>
EntityField HackageCabal typ
HackageCabalId forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
>. Key HackageCabal
hackageCabalId
    | Just Key HackageCabal
hackageCabalId <- [Maybe (Key HackageCabal)
mhackageCabalId]
    ]

getBlobKey :: BlobId -> ReaderT SqlBackend (RIO env) BlobKey
getBlobKey :: forall env. Key Blob -> ReaderT SqlBackend (RIO env) BlobKey
getBlobKey Key Blob
bid = do
  [(Single SHA256, Single FileSize)]
res <- forall a (m :: * -> *) backend.
(RawSql a, MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m [a]
rawSql Text
"SELECT sha, size FROM blob WHERE id=?" [forall a. PersistField a => a -> PersistValue
toPersistValue Key Blob
bid]
  case [(Single SHA256, Single FileSize)]
res of
    [] -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"getBlobKey failed due to missing ID: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Key Blob
bid
    [(Single SHA256
sha, Single FileSize
size)] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SHA256 -> FileSize -> BlobKey
P.BlobKey SHA256
sha FileSize
size
    [(Single SHA256, Single FileSize)]
_ -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"getBlobKey failed due to non-unique ID: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Key Blob
bid, [(Single SHA256, Single FileSize)]
res)

getBlobId :: BlobKey -> ReaderT SqlBackend (RIO env) (Maybe BlobId)
getBlobId :: forall env.
BlobKey -> ReaderT SqlBackend (RIO env) (Maybe (Key Blob))
getBlobId (P.BlobKey SHA256
sha FileSize
size) = do
  [Single (Key Blob)]
res <- forall a (m :: * -> *) backend.
(RawSql a, MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m [a]
rawSql Text
"SELECT id FROM blob WHERE sha=? AND size=?"
           [forall a. PersistField a => a -> PersistValue
toPersistValue SHA256
sha, forall a. PersistField a => a -> PersistValue
toPersistValue FileSize
size]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Single a -> a
unSingle [Single (Key Blob)]
res

loadURLBlob :: Text -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
loadURLBlob :: forall env. Text -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
loadURLBlob Text
url = do
  [Single ByteString]
ment <- forall a (m :: * -> *) backend.
(RawSql a, MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m [a]
rawSql
    Text
"SELECT blob.contents\n\
    \FROM blob, url_blob\n\
    \WHERE url=?\
    \  AND url_blob.blob=blob.id\n\
    \ ORDER BY url_blob.time DESC"
    [forall a. PersistField a => a -> PersistValue
toPersistValue Text
url]
  case [Single ByteString]
ment of
    [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    (Single ByteString
bs) : [Single ByteString]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ByteString
bs

storeURLBlob :: Text -> ByteString -> ReaderT SqlBackend (RIO env) ()
storeURLBlob :: forall env. Text -> ByteString -> ReaderT SqlBackend (RIO env) ()
storeURLBlob Text
url ByteString
blob = do
  (Key Blob
blobId, BlobKey
_) <- forall env.
ByteString -> ReaderT SqlBackend (RIO env) (Key Blob, BlobKey)
storeBlob ByteString
blob
  UTCTime
now <- forall (m :: * -> *). MonadIO m => m UTCTime
getCurrentTime
  forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m ()
insert_ UrlBlob
        { urlBlobUrl :: Text
urlBlobUrl = Text
url
        , urlBlobBlob :: Key Blob
urlBlobBlob = Key Blob
blobId
        , urlBlobTime :: UTCTime
urlBlobTime = UTCTime
now
        }

clearHackageRevisions :: ReaderT SqlBackend (RIO env) ()
clearHackageRevisions :: forall env. ReaderT SqlBackend (RIO env) ()
clearHackageRevisions = forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere ([] :: [Filter HackageCabal])

storeHackageRevision ::
     P.PackageName
  -> P.Version
  -> BlobId
  -> ReaderT SqlBackend (RIO env) ()
storeHackageRevision :: forall env.
PackageName
-> Version -> Key Blob -> ReaderT SqlBackend (RIO env) ()
storeHackageRevision PackageName
name Version
version Key Blob
key = do
  Key PackageName
nameid <- forall env.
PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
getPackageNameId PackageName
name
  Key Version
versionid <- forall env. Version -> ReaderT SqlBackend (RIO env) (Key Version)
getVersionId Version
version
  Int
rev <- forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m Int
count
    [ forall typ. (typ ~ Key PackageName) => EntityField HackageCabal typ
HackageCabalName forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key PackageName
nameid
    , forall typ. (typ ~ Key Version) => EntityField HackageCabal typ
HackageCabalVersion forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key Version
versionid
    ]
  forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m ()
insert_ HackageCabal
    { hackageCabalName :: Key PackageName
hackageCabalName = Key PackageName
nameid
    , hackageCabalVersion :: Key Version
hackageCabalVersion = Key Version
versionid
    , hackageCabalRevision :: Revision
hackageCabalRevision = Word -> Revision
Revision (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
rev)
    , hackageCabalCabal :: Key Blob
hackageCabalCabal = Key Blob
key
    , hackageCabalTree :: Maybe (Key Tree)
hackageCabalTree = forall a. Maybe a
Nothing
    }

loadHackagePackageVersions ::
     P.PackageName
  -> ReaderT SqlBackend (RIO env) (Map P.Version (Map Revision BlobKey))
loadHackagePackageVersions :: forall env.
PackageName
-> ReaderT
     SqlBackend (RIO env) (Map Version (Map Revision BlobKey))
loadHackagePackageVersions PackageName
name = do
  Key PackageName
nameid <- forall env.
PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
getPackageNameId PackageName
name
  -- would be better with esqueleto

  forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {k}.
(Single k, Single VersionP, Single SHA256, Single FileSize)
-> (Version, Map k BlobKey)
go forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *) backend.
(RawSql a, MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m [a]
rawSql
    Text
"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"
    [forall a. PersistField a => a -> PersistValue
toPersistValue Key PackageName
nameid]
  where
    go :: (Single k, Single VersionP, Single SHA256, Single FileSize)
-> (Version, Map k BlobKey)
go (Single k
revision, Single (P.VersionP Version
version), Single SHA256
key, Single FileSize
size) =
      (Version
version, forall k a. k -> a -> Map k a
Map.singleton k
revision (SHA256 -> FileSize -> BlobKey
P.BlobKey SHA256
key FileSize
size))

loadHackagePackageVersion ::
     P.PackageName
  -> P.Version
  -> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, P.BlobKey))
loadHackagePackageVersion :: forall env.
PackageName
-> Version
-> ReaderT SqlBackend (RIO env) (Map Revision (Key Blob, BlobKey))
loadHackagePackageVersion PackageName
name Version
version = do
  Key PackageName
nameid <- forall env.
PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
getPackageNameId PackageName
name
  Key Version
versionid <- forall env. Version -> ReaderT SqlBackend (RIO env) (Key Version)
getVersionId Version
version
  -- would be better with esqueleto

  forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a}.
(Single a, Single SHA256, Single FileSize, Single a)
-> (a, (a, BlobKey))
go forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *) backend.
(RawSql a, MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m [a]
rawSql
    Text
"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"
    [forall a. PersistField a => a -> PersistValue
toPersistValue Key PackageName
nameid, forall a. PersistField a => a -> PersistValue
toPersistValue Key Version
versionid]
 where
  go :: (Single a, Single SHA256, Single FileSize, Single a)
-> (a, (a, BlobKey))
go (Single a
revision, Single SHA256
sha, Single FileSize
size, Single a
bid) =
    (a
revision, (a
bid, SHA256 -> FileSize -> BlobKey
P.BlobKey SHA256
sha FileSize
size))

loadLatestCacheUpdate ::
  ReaderT SqlBackend (RIO env) (Maybe (FileSize, SHA256))
loadLatestCacheUpdate :: forall env. ReaderT SqlBackend (RIO env) (Maybe (FileSize, SHA256))
loadLatestCacheUpdate = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Entity CacheUpdate -> (FileSize, SHA256)
go forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m (Maybe (Entity record))
selectFirst [] [forall record typ. EntityField record typ -> SelectOpt record
Desc forall typ. (typ ~ UTCTime) => EntityField CacheUpdate typ
CacheUpdateTime]
 where
  go :: Entity CacheUpdate -> (FileSize, SHA256)
go (Entity Key CacheUpdate
_ CacheUpdate
cu) = (CacheUpdate -> FileSize
cacheUpdateSize CacheUpdate
cu, CacheUpdate -> SHA256
cacheUpdateSha CacheUpdate
cu)

storeCacheUpdate :: FileSize -> SHA256 -> ReaderT SqlBackend (RIO env) ()
storeCacheUpdate :: forall env. FileSize -> SHA256 -> ReaderT SqlBackend (RIO env) ()
storeCacheUpdate FileSize
size SHA256
sha = do
  UTCTime
now <- forall (m :: * -> *). MonadIO m => m UTCTime
getCurrentTime
  forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m ()
insert_ CacheUpdate
    { cacheUpdateTime :: UTCTime
cacheUpdateTime = UTCTime
now
    , cacheUpdateSize :: FileSize
cacheUpdateSize = FileSize
size
    , cacheUpdateSha :: SHA256
cacheUpdateSha = SHA256
sha
    }

storeHackageTarballInfo ::
     P.PackageName
  -> P.Version
  -> SHA256
  -> FileSize
  -> ReaderT SqlBackend (RIO env) ()
storeHackageTarballInfo :: forall env.
PackageName
-> Version -> SHA256 -> FileSize -> ReaderT SqlBackend (RIO env) ()
storeHackageTarballInfo PackageName
name Version
version SHA256
sha FileSize
size = do
  Key PackageName
nameid <- forall env.
PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
getPackageNameId PackageName
name
  Key Version
versionid <- forall env. Version -> ReaderT SqlBackend (RIO env) (Key Version)
getVersionId Version
version
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall record backend (m :: * -> *).
(MonadIO m, PersistUniqueWrite backend,
 PersistRecordBackend record backend, AtLeastOneUniqueKey record,
 SafeToInsert record) =>
record -> ReaderT backend m (Either (Entity record) (Key record))
insertBy HackageTarball
    { hackageTarballName :: Key PackageName
hackageTarballName = Key PackageName
nameid
    , hackageTarballVersion :: Key Version
hackageTarballVersion = Key Version
versionid
    , hackageTarballSha :: SHA256
hackageTarballSha = SHA256
sha
    , hackageTarballSize :: FileSize
hackageTarballSize = FileSize
size
    }

loadHackageTarballInfo ::
     P.PackageName
  -> P.Version
  -> ReaderT SqlBackend (RIO env) (Maybe (SHA256, FileSize))
loadHackageTarballInfo :: forall env.
PackageName
-> Version
-> ReaderT SqlBackend (RIO env) (Maybe (SHA256, FileSize))
loadHackageTarballInfo PackageName
name Version
version = do
  Key PackageName
nameid <- forall env.
PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
getPackageNameId PackageName
name
  Key Version
versionid <- forall env. Version -> ReaderT SqlBackend (RIO env) (Key Version)
getVersionId Version
version
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Entity HackageTarball -> (SHA256, FileSize)
go forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
getBy (Key PackageName -> Key Version -> Unique HackageTarball
UniqueHackageTarball Key PackageName
nameid Key Version
versionid)
 where
  go :: Entity HackageTarball -> (SHA256, FileSize)
go (Entity Key HackageTarball
_ HackageTarball
ht) = (HackageTarball -> SHA256
hackageTarballSha HackageTarball
ht, HackageTarball -> FileSize
hackageTarballSize HackageTarball
ht)

storeCabalFile ::
     ByteString
  -> P.PackageName
  -> ReaderT SqlBackend (RIO env) BlobId
storeCabalFile :: forall env.
ByteString
-> PackageName -> ReaderT SqlBackend (RIO env) (Key Blob)
storeCabalFile ByteString
cabalBS PackageName
pkgName = do
  (Key Blob
bid, BlobKey
_) <- forall env.
ByteString -> ReaderT SqlBackend (RIO env) (Key Blob, BlobKey)
storeBlob ByteString
cabalBS
  let cabalFile :: SafeFilePath
cabalFile = PackageName -> SafeFilePath
P.cabalFileName PackageName
pkgName
  Either (Entity FilePath) (Key FilePath)
_ <- forall record backend (m :: * -> *).
(MonadIO m, PersistUniqueWrite backend,
 PersistRecordBackend record backend, AtLeastOneUniqueKey record,
 SafeToInsert record) =>
record -> ReaderT backend m (Either (Entity record) (Key record))
insertBy FilePath {filePathPath :: SafeFilePath
filePathPath = SafeFilePath
cabalFile}
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Key Blob
bid

loadFilePath ::
     SafeFilePath
  -> ReaderT SqlBackend (RIO env) (Entity FilePath)
loadFilePath :: forall env.
SafeFilePath -> ReaderT SqlBackend (RIO env) (Entity FilePath)
loadFilePath SafeFilePath
path = do
  Maybe (Entity FilePath)
fp <- forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
getBy forall a b. (a -> b) -> a -> b
$ SafeFilePath -> Unique FilePath
UniqueSfp SafeFilePath
path
  case Maybe (Entity FilePath)
fp of
    Maybe (Entity FilePath)
Nothing -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
      String
"loadFilePath: No row found for " forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (SafeFilePath -> Text
P.unSafeFilePath SafeFilePath
path)
    Just Entity FilePath
record -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Entity FilePath
record

loadHPackTreeEntity :: TreeId -> ReaderT SqlBackend (RIO env) (Entity TreeEntry)
loadHPackTreeEntity :: forall env.
Key Tree -> ReaderT SqlBackend (RIO env) (Entity TreeEntry)
loadHPackTreeEntity Key Tree
tid = do
  Entity FilePath
filepath <- forall env.
SafeFilePath -> ReaderT SqlBackend (RIO env) (Entity FilePath)
loadFilePath SafeFilePath
P.hpackSafeFilePath
  let Key FilePath
filePathId :: FilePathId = forall record. Entity record -> Key record
entityKey Entity FilePath
filepath
  Maybe (Entity TreeEntry)
hpackTreeEntry <-
    forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m (Maybe (Entity record))
selectFirst [forall typ. (typ ~ Key Tree) => EntityField TreeEntry typ
TreeEntryTree forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key Tree
tid, forall typ. (typ ~ Key FilePath) => EntityField TreeEntry typ
TreeEntryPath forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key FilePath
filePathId] []
  case Maybe (Entity TreeEntry)
hpackTreeEntry of
    Maybe (Entity TreeEntry)
Nothing -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
         String
"loadHPackTreeEntity: No package.yaml file found in TreeEntry for TreeId:  "
      forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Key Tree
tid
    Just Entity TreeEntry
record -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Entity TreeEntry
record

storeHPack ::
     (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => P.RawPackageLocationImmutable
  -> TreeId
  -> ReaderT SqlBackend (RIO env) (Key HPack)
storeHPack :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> Key Tree -> ReaderT SqlBackend (RIO env) (Key HPack)
storeHPack RawPackageLocationImmutable
rpli Key Tree
tid = do
  Key Version
vid <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
ReaderT SqlBackend (RIO env) (Key Version)
hpackVersionId
  Maybe (Entity HPack)
hpackRecord <- forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
getBy (Key Tree -> Key Version -> Unique HPack
UniqueHPack Key Tree
tid Key Version
vid)
  case Maybe (Entity HPack)
hpackRecord of
    Maybe (Entity HPack)
Nothing -> forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> Key Tree
-> Key Version
-> ReaderT SqlBackend (RIO env) (Key HPack)
generateHPack RawPackageLocationImmutable
rpli Key Tree
tid Key Version
vid
    Just Entity HPack
record -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall record. Entity record -> Key record
entityKey Entity HPack
record

loadCabalBlobKey :: HPackId -> ReaderT SqlBackend (RIO env) BlobKey
loadCabalBlobKey :: forall env. Key HPack -> ReaderT SqlBackend (RIO env) BlobKey
loadCabalBlobKey Key HPack
hpackId = do
  HPack
hpackRecord <- forall record backend (m :: * -> *).
(PersistStoreRead backend, PersistRecordBackend record backend,
 MonadIO m) =>
Key record -> ReaderT backend m record
getJust Key HPack
hpackId
  forall env. Key Blob -> ReaderT SqlBackend (RIO env) BlobKey
getBlobKey forall a b. (a -> b) -> a -> b
$ HPack -> Key Blob
hPackCabalBlob HPack
hpackRecord

generateHPack ::
     (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => P.RawPackageLocationImmutable -- ^ for exceptions

  -> TreeId
  -> VersionId
  -> ReaderT SqlBackend (RIO env) (Key HPack)
generateHPack :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> Key Tree
-> Key Version
-> ReaderT SqlBackend (RIO env) (Key HPack)
generateHPack RawPackageLocationImmutable
rpli Key Tree
tid Key Version
vid = do
  Tree
tree <- forall env. Key Tree -> ReaderT SqlBackend (RIO env) Tree
getTree Key Tree
tid
  (PackageName
pkgName, ByteString
cabalBS) <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> Tree -> ReaderT SqlBackend (RIO env) (PackageName, ByteString)
hpackToCabalS RawPackageLocationImmutable
rpli Tree
tree
  Key Blob
bid <- forall env.
ByteString
-> PackageName -> ReaderT SqlBackend (RIO env) (Key Blob)
storeCabalFile ByteString
cabalBS PackageName
pkgName
  let cabalFile :: SafeFilePath
cabalFile = PackageName -> SafeFilePath
P.cabalFileName PackageName
pkgName
  Either (Entity FilePath) (Key FilePath)
fid <- forall record backend (m :: * -> *).
(MonadIO m, PersistUniqueWrite backend,
 PersistRecordBackend record backend, AtLeastOneUniqueKey record,
 SafeToInsert record) =>
record -> ReaderT backend m (Either (Entity record) (Key record))
insertBy FilePath {filePathPath :: SafeFilePath
filePathPath = SafeFilePath
cabalFile}
  let hpackRecord :: HPack
hpackRecord =
        HPack
          { hPackTree :: Key Tree
hPackTree = Key Tree
tid
          , hPackVersion :: Key Version
hPackVersion = Key Version
vid
          , hPackCabalBlob :: Key Blob
hPackCabalBlob = Key Blob
bid
          , hPackCabalPath :: Key FilePath
hPackCabalPath = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall record. Entity record -> Key record
entityKey forall a. a -> a
id Either (Entity FilePath) (Key FilePath)
fid
          }
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall record. Entity record -> Key record
entityKey forall a. a -> a
id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall record backend (m :: * -> *).
(MonadIO m, PersistUniqueWrite backend,
 PersistRecordBackend record backend, AtLeastOneUniqueKey record,
 SafeToInsert record) =>
record -> ReaderT backend m (Either (Entity record) (Key record))
insertBy HPack
hpackRecord


hpackVersionId ::
     (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => ReaderT SqlBackend (RIO env) VersionId
hpackVersionId :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
ReaderT SqlBackend (RIO env) (Key Version)
hpackVersionId = do
  Version
hpackSoftwareVersion <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RIO env Version
hpackVersion
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall record. Entity record -> Key record
entityKey forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$
    forall record backend (m :: * -> *).
(MonadIO m, PersistUniqueWrite backend,
 PersistRecordBackend record backend, AtLeastOneUniqueKey record,
 SafeToInsert record) =>
record -> ReaderT backend m (Either (Entity record) (Key record))
insertBy forall a b. (a -> b) -> a -> b
$
    Version {versionVersion :: VersionP
versionVersion = Version -> VersionP
P.VersionP Version
hpackSoftwareVersion}


getFilePathId :: SafeFilePath -> ReaderT SqlBackend (RIO env) FilePathId
getFilePathId :: forall env.
SafeFilePath -> ReaderT SqlBackend (RIO env) (Key FilePath)
getFilePathId SafeFilePath
sfp =
  forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Key record]
selectKeysList [forall typ. (typ ~ SafeFilePath) => EntityField FilePath typ
FilePathPath forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. SafeFilePath
sfp] [] forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    [Key FilePath
fpId] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Key FilePath
fpId
    [] ->
      forall env a. RdbmsActions env a -> ReaderT SqlBackend (RIO env) a
rdbmsAwareQuery
        RdbmsActions
          { raSqlite :: ReaderT SqlBackend (RIO env) (Key FilePath)
raSqlite = forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m (Key record)
insert forall a b. (a -> b) -> a -> b
$ SafeFilePath -> FilePath
FilePath SafeFilePath
sfp
          , raPostgres :: ReaderT SqlBackend (RIO env) (Key FilePath)
raPostgres = do
              forall (m :: * -> *) backend.
(MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m ()
rawExecute
                Text
"INSERT INTO file_path(path) VALUES (?) ON CONFLICT DO NOTHING"
                [forall a. PersistField a => a -> PersistValue
toPersistValue SafeFilePath
sfp]
              forall a (m :: * -> *) backend.
(RawSql a, MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m [a]
rawSql
                Text
"SELECT id FROM file_path WHERE path = ?"
                [forall a. PersistField a => a -> PersistValue
toPersistValue SafeFilePath
sfp] forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                [Single Key FilePath
key] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Key FilePath
key
                [Single (Key FilePath)]
_ -> forall a. HasCallStack => String -> a
error
                  String
"getFilePathId: there was a critical problem storing a blob."
          }
    [Key FilePath]
_ ->
      forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
      String
"getFilePathId: FilePath unique constraint key is violated for: " forall a. [a] -> [a] -> [a]
++ String
fp
 where
  fp :: String
fp = Text -> String
T.unpack (SafeFilePath -> Text
P.unSafeFilePath SafeFilePath
sfp)

-- | A tree that has already been stored in the database

newtype CachedTree
  = CachedTreeMap (Map SafeFilePath (P.TreeEntry, BlobId))
  deriving Int -> CachedTree -> ShowS
[CachedTree] -> ShowS
CachedTree -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CachedTree] -> ShowS
$cshowList :: [CachedTree] -> ShowS
show :: CachedTree -> String
$cshow :: CachedTree -> String
showsPrec :: Int -> CachedTree -> ShowS
$cshowsPrec :: Int -> CachedTree -> ShowS
Show

unCachedTree :: CachedTree -> P.Tree
unCachedTree :: CachedTree -> Tree
unCachedTree (CachedTreeMap Map SafeFilePath (TreeEntry, Key Blob)
m) = Map SafeFilePath TreeEntry -> Tree
P.TreeMap forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map SafeFilePath (TreeEntry, Key Blob)
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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> PackageIdentifier
-> CachedTree
-> BuildFile
-> ReaderT SqlBackend (RIO env) (Key Tree, TreeKey)
storeTree RawPackageLocationImmutable
rpli (P.PackageIdentifier PackageName
name Version
version) tree :: CachedTree
tree@(CachedTreeMap Map SafeFilePath (TreeEntry, Key Blob)
m) BuildFile
buildFile = do
  (Key Blob
bid, BlobKey
blobKey) <- forall env.
ByteString -> ReaderT SqlBackend (RIO env) (Key Blob, BlobKey)
storeBlob forall a b. (a -> b) -> a -> b
$ Tree -> ByteString
P.renderTree forall a b. (a -> b) -> a -> b
$ CachedTree -> Tree
unCachedTree CachedTree
tree
  (Maybe (Key Blob)
cabalid, FileType
ftype) <- case BuildFile
buildFile of
    P.BFHpack (P.TreeEntry BlobKey
_ FileType
ftype) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Maybe a
Nothing, FileType
ftype)
    P.BFCabal SafeFilePath
_ (P.TreeEntry (P.BlobKey SHA256
btypeSha FileSize
_) FileType
ftype) -> do
      Maybe (Key Blob)
buildTypeid <- forall env.
SHA256 -> ReaderT SqlBackend (RIO env) (Maybe (Key Blob))
loadBlobBySHA SHA256
btypeSha
      Key Blob
buildid <-
        case Maybe (Key Blob)
buildTypeid of
          Just Key Blob
buildId -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Key Blob
buildId
          Maybe (Key Blob)
Nothing -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
               String
"storeTree: "
            forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show BuildFile
buildFile
            forall a. [a] -> [a] -> [a]
++ String
" BlobKey not found: "
            forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (CachedTree
tree, SHA256
btypeSha)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just Key Blob
buildid, FileType
ftype)
  Key PackageName
nameid <- forall env.
PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
getPackageNameId PackageName
name
  Key Version
versionid <- forall env. Version -> ReaderT SqlBackend (RIO env) (Key Version)
getVersionId Version
version
  Either (Entity Tree) (Key Tree)
etid <- forall record backend (m :: * -> *).
(MonadIO m, PersistUniqueWrite backend,
 PersistRecordBackend record backend, AtLeastOneUniqueKey record,
 SafeToInsert record) =>
record -> ReaderT backend m (Either (Entity record) (Key record))
insertBy Tree
    { treeKey :: Key Blob
treeKey = Key Blob
bid
    , treeCabal :: Maybe (Key Blob)
treeCabal = Maybe (Key Blob)
cabalid
    , treeCabalType :: FileType
treeCabalType = FileType
ftype
    , treeName :: Key PackageName
treeName = Key PackageName
nameid
    , treeVersion :: Key Version
treeVersion = Key Version
versionid
    }

  (Key Tree
tid, TreeKey
pTreeKey) <- case Either (Entity Tree) (Key Tree)
etid of
    Left (Entity Key Tree
tid Tree
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Key Tree
tid, BlobKey -> TreeKey
P.TreeKey BlobKey
blobKey) -- already in database, assume it matches

    Right Key Tree
tid -> do
      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall k a. Map k a -> [(k, a)]
Map.toList Map SafeFilePath (TreeEntry, Key Blob)
m) forall a b. (a -> b) -> a -> b
$ \(SafeFilePath
sfp, (P.TreeEntry BlobKey
_blobKey FileType
ft, Key Blob
bid')) -> do
        Key FilePath
sfpid <- forall env.
SafeFilePath -> ReaderT SqlBackend (RIO env) (Key FilePath)
getFilePathId SafeFilePath
sfp
        forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m ()
insert_ TreeEntry
          { treeEntryTree :: Key Tree
treeEntryTree = Key Tree
tid
          , treeEntryPath :: Key FilePath
treeEntryPath = Key FilePath
sfpid
          , treeEntryBlob :: Key Blob
treeEntryBlob = Key Blob
bid'
          , treeEntryType :: FileType
treeEntryType = FileType
ft
          }
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (Key Tree
tid, BlobKey -> TreeKey
P.TreeKey BlobKey
blobKey)
  case BuildFile
buildFile of
    P.BFHpack TreeEntry
_ -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> Key Tree -> ReaderT SqlBackend (RIO env) (Key HPack)
storeHPack RawPackageLocationImmutable
rpli Key Tree
tid
    P.BFCabal SafeFilePath
_ TreeEntry
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Key Tree
tid, TreeKey
pTreeKey)

getTree :: TreeId -> ReaderT SqlBackend (RIO env) P.Tree
getTree :: forall env. Key Tree -> ReaderT SqlBackend (RIO env) Tree
getTree Key Tree
tid = do
  (Maybe Tree
mts :: Maybe Tree) <- forall backend record (m :: * -> *).
(PersistStoreRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
get Key Tree
tid
  Tree
ts <-
      case Maybe Tree
mts of
        Maybe Tree
Nothing ->
            forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"getTree: invalid foreign key " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Key Tree
tid
        Just Tree
ts -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Tree
ts
  forall env. Entity Tree -> ReaderT SqlBackend (RIO env) Tree
loadTreeByEnt forall a b. (a -> b) -> a -> b
$ forall record. Key record -> record -> Entity record
Entity Key Tree
tid Tree
ts

loadTree :: P.TreeKey -> ReaderT SqlBackend (RIO env) (Maybe P.Tree)
loadTree :: forall env. TreeKey -> ReaderT SqlBackend (RIO env) (Maybe Tree)
loadTree TreeKey
key = do
  Maybe (Entity Tree)
ment <- forall env.
TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
getTreeForKey TreeKey
key
  case Maybe (Entity Tree)
ment of
    Maybe (Entity Tree)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    Just Entity Tree
ent -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env. Entity Tree -> ReaderT SqlBackend (RIO env) Tree
loadTreeByEnt Entity Tree
ent

getTreeForKey ::
     TreeKey
  -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
getTreeForKey :: forall env.
TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
getTreeForKey (P.TreeKey BlobKey
key) = do
  Maybe (Key Blob)
mbid <- forall env.
BlobKey -> ReaderT SqlBackend (RIO env) (Maybe (Key Blob))
getBlobId BlobKey
key
  case Maybe (Key Blob)
mbid of
    Maybe (Key Blob)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    Just Key Blob
bid -> forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
getBy forall a b. (a -> b) -> a -> b
$ Key Blob -> Unique Tree
UniqueTree Key Blob
bid

loadPackageById ::
       (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
    => P.RawPackageLocationImmutable -- ^ for exceptions

    -> TreeId
    -> ReaderT SqlBackend (RIO env) Package
loadPackageById :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> Key Tree -> ReaderT SqlBackend (RIO env) Package
loadPackageById RawPackageLocationImmutable
rpli Key Tree
tid = do
  (Maybe Tree
mts :: Maybe Tree) <- forall backend record (m :: * -> *).
(PersistStoreRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
get Key Tree
tid
  Tree
ts <- case Maybe Tree
mts of
    Maybe Tree
Nothing ->
      forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"loadPackageById: invalid foreign key " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Key Tree
tid
    Just Tree
ts -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Tree
ts
  (Tree
tree :: P.Tree) <- forall env. Entity Tree -> ReaderT SqlBackend (RIO env) Tree
loadTreeByEnt forall a b. (a -> b) -> a -> b
$ forall record. Key record -> record -> Entity record
Entity Key Tree
tid Tree
ts
  (BlobKey
blobKey :: BlobKey) <- forall env. Key Blob -> ReaderT SqlBackend (RIO env) BlobKey
getBlobKey forall a b. (a -> b) -> a -> b
$ Tree -> Key Blob
treeKey Tree
ts
  (Maybe PackageName
mname :: Maybe PackageName) <- forall backend record (m :: * -> *).
(PersistStoreRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
get forall a b. (a -> b) -> a -> b
$ Tree -> Key PackageName
treeName Tree
ts
  PackageName
name <- case Maybe PackageName
mname of
    Maybe PackageName
Nothing -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
      String
"loadPackageByid: invalid foreign key " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Tree -> Key PackageName
treeName Tree
ts)
    Just (PackageName (P.PackageNameP PackageName
name)) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageName
name
  Maybe Version
mversion <- forall backend record (m :: * -> *).
(PersistStoreRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
get forall a b. (a -> b) -> a -> b
$ Tree -> Key Version
treeVersion Tree
ts
  Version
version <- case Maybe Version
mversion of
    Maybe Version
Nothing -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
      String
"loadPackageByid: invalid foreign key " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Tree -> Key Version
treeVersion Tree
ts)
    Just (Version (P.VersionP Version
version)) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Version
version
  let ident :: PackageIdentifier
ident = PackageName -> Version -> PackageIdentifier
P.PackageIdentifier PackageName
name Version
version
  (PackageCabal
packageEntry, Tree
mtree) <- case Tree -> Maybe (Key Blob)
treeCabal Tree
ts of
    Just Key Blob
keyBlob -> do
      BlobKey
cabalKey <- forall env. Key Blob -> ReaderT SqlBackend (RIO env) BlobKey
getBlobKey Key Blob
keyBlob
      forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( TreeEntry -> PackageCabal
P.PCCabalFile forall a b. (a -> b) -> a -> b
$ BlobKey -> FileType -> TreeEntry
P.TreeEntry BlobKey
cabalKey (Tree -> FileType
treeCabalType Tree
ts)
        , Tree
tree)
    Maybe (Key Blob)
Nothing -> do
      Key Version
hpackVid <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
ReaderT SqlBackend (RIO env) (Key Version)
hpackVersionId
      Maybe (Entity HPack)
hpackEntity <- forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
getBy (Key Tree -> Key Version -> Unique HPack
UniqueHPack Key Tree
tid Key Version
hpackVid)
      let (P.TreeMap Map SafeFilePath TreeEntry
tmap) = Tree
tree
          cabalFile :: SafeFilePath
cabalFile = PackageName -> SafeFilePath
P.cabalFileName PackageName
name
      case Maybe (Entity HPack)
hpackEntity of
        Maybe (Entity HPack)
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.

          (Key HPack
hpackId :: HPackId) <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> Key Tree -> ReaderT SqlBackend (RIO env) (Key HPack)
storeHPack RawPackageLocationImmutable
rpli Key Tree
tid
          HPack
hpackRecord <- forall record backend (m :: * -> *).
(PersistStoreRead backend, PersistRecordBackend record backend,
 MonadIO m) =>
Key record -> ReaderT backend m record
getJust Key HPack
hpackId
          forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
HPack
-> Tree
-> Map SafeFilePath TreeEntry
-> SafeFilePath
-> ReaderT SqlBackend (RIO env) (PackageCabal, Tree)
getHPackCabalFile HPack
hpackRecord Tree
ts Map SafeFilePath TreeEntry
tmap SafeFilePath
cabalFile
        Just (Entity Key HPack
_ HPack
item) ->
          forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
HPack
-> Tree
-> Map SafeFilePath TreeEntry
-> SafeFilePath
-> ReaderT SqlBackend (RIO env) (PackageCabal, Tree)
getHPackCabalFile HPack
item Tree
ts Map SafeFilePath TreeEntry
tmap SafeFilePath
cabalFile
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    Package
      { packageTreeKey :: TreeKey
packageTreeKey = BlobKey -> TreeKey
P.TreeKey BlobKey
blobKey
      , packageTree :: Tree
packageTree = Tree
mtree
      , packageCabalEntry :: PackageCabal
packageCabalEntry = PackageCabal
packageEntry
      , packageIdent :: PackageIdentifier
packageIdent = PackageIdentifier
ident
      }

getHPackBlobKey :: HPack -> ReaderT SqlBackend (RIO env) BlobKey
getHPackBlobKey :: forall env. HPack -> ReaderT SqlBackend (RIO env) BlobKey
getHPackBlobKey HPack
hpackRecord = do
  let treeId :: Key Tree
treeId = HPack -> Key Tree
hPackTree HPack
hpackRecord
  Entity TreeEntry
hpackEntity <- forall env.
Key Tree -> ReaderT SqlBackend (RIO env) (Entity TreeEntry)
loadHPackTreeEntity Key Tree
treeId
  forall env. Key Blob -> ReaderT SqlBackend (RIO env) BlobKey
getBlobKey (TreeEntry -> Key Blob
treeEntryBlob forall a b. (a -> b) -> a -> b
$ forall record. Entity record -> record
entityVal Entity TreeEntry
hpackEntity)

getHPackBlobKeyById :: HPackId -> ReaderT SqlBackend (RIO env) BlobKey
getHPackBlobKeyById :: forall env. Key HPack -> ReaderT SqlBackend (RIO env) BlobKey
getHPackBlobKeyById Key HPack
hpackId = do
  HPack
hpackRecord <- forall record backend (m :: * -> *).
(PersistStoreRead backend, PersistRecordBackend record backend,
 MonadIO m) =>
Key record -> ReaderT backend m record
getJust Key HPack
hpackId
  forall env. HPack -> ReaderT SqlBackend (RIO env) BlobKey
getHPackBlobKey HPack
hpackRecord

getHPackCabalFile ::
     (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => HPack
  -> Tree
  -> Map SafeFilePath P.TreeEntry
  -> SafeFilePath
  -> ReaderT SqlBackend (RIO env) (P.PackageCabal, P.Tree)
getHPackCabalFile :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
HPack
-> Tree
-> Map SafeFilePath TreeEntry
-> SafeFilePath
-> ReaderT SqlBackend (RIO env) (PackageCabal, Tree)
getHPackCabalFile HPack
hpackRecord Tree
ts Map SafeFilePath TreeEntry
tmap SafeFilePath
cabalFile = do
  BlobKey
cabalKey <- forall env. Key Blob -> ReaderT SqlBackend (RIO env) BlobKey
getBlobKey (HPack -> Key Blob
hPackCabalBlob HPack
hpackRecord)
  BlobKey
hpackKey <- forall env. HPack -> ReaderT SqlBackend (RIO env) BlobKey
getHPackBlobKey HPack
hpackRecord
  Version
hpackSoftwareVersion <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RIO env Version
hpackVersion
  let fileType :: FileType
fileType = Tree -> FileType
treeCabalType Tree
ts
      cbTreeEntry :: TreeEntry
cbTreeEntry = BlobKey -> FileType -> TreeEntry
P.TreeEntry BlobKey
cabalKey FileType
fileType
      hpackTreeEntry :: TreeEntry
hpackTreeEntry = BlobKey -> FileType -> TreeEntry
P.TreeEntry BlobKey
hpackKey FileType
fileType
      tree :: Tree
tree = Map SafeFilePath TreeEntry -> Tree
P.TreeMap forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert SafeFilePath
cabalFile TreeEntry
cbTreeEntry Map SafeFilePath TreeEntry
tmap
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( PHpack -> PackageCabal
P.PCHpack forall a b. (a -> b) -> a -> b
$
      P.PHpack
          { phOriginal :: TreeEntry
P.phOriginal = TreeEntry
hpackTreeEntry
          , phGenerated :: TreeEntry
P.phGenerated = TreeEntry
cbTreeEntry
          , phVersion :: Version
P.phVersion = Version
hpackSoftwareVersion
          }
    , Tree
tree
    )

loadTreeByEnt :: Entity Tree -> ReaderT SqlBackend (RIO env) P.Tree
loadTreeByEnt :: forall env. Entity Tree -> ReaderT SqlBackend (RIO env) Tree
loadTreeByEnt (Entity Key Tree
tid Tree
_t) = do
  [(Single SafeFilePath, Single SHA256, Single FileSize,
  Single FileType)]
entries <- forall a (m :: * -> *) backend.
(RawSql a, MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m [a]
rawSql
    Text
"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"
    [forall a. PersistField a => a -> PersistValue
toPersistValue Key Tree
tid]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Map SafeFilePath TreeEntry -> Tree
P.TreeMap forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map
    (\(Single SafeFilePath
sfp, Single SHA256
sha, Single FileSize
size, Single FileType
ft) ->
         (SafeFilePath
sfp, BlobKey -> FileType -> TreeEntry
P.TreeEntry (SHA256 -> FileSize -> BlobKey
P.BlobKey SHA256
sha FileSize
size) FileType
ft))
    [(Single SafeFilePath, Single SHA256, Single FileSize,
  Single FileType)]
entries

storeHackageTree ::
     P.PackageName
  -> P.Version
  -> BlobId
  -> P.TreeKey
  -> ReaderT SqlBackend (RIO env) ()
storeHackageTree :: forall env.
PackageName
-> Version
-> Key Blob
-> TreeKey
-> ReaderT SqlBackend (RIO env) ()
storeHackageTree PackageName
name Version
version Key Blob
cabal TreeKey
treeKey' = do
  Key PackageName
nameid <- forall env.
PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
getPackageNameId PackageName
name
  Key Version
versionid <- forall env. Version -> ReaderT SqlBackend (RIO env) (Key Version)
getVersionId Version
version
  Maybe (Entity Tree)
ment <- forall env.
TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
getTreeForKey TreeKey
treeKey'
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (Entity Tree)
ment forall a b. (a -> b) -> a -> b
$ \Entity Tree
ent -> forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> [Update record] -> ReaderT backend m ()
updateWhere
    [ forall typ. (typ ~ Key PackageName) => EntityField HackageCabal typ
HackageCabalName forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key PackageName
nameid
    , forall typ. (typ ~ Key Version) => EntityField HackageCabal typ
HackageCabalVersion forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key Version
versionid
    , forall typ. (typ ~ Key Blob) => EntityField HackageCabal typ
HackageCabalCabal forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key Blob
cabal
    ]
    [forall typ.
(typ ~ Maybe (Key Tree)) =>
EntityField HackageCabal typ
HackageCabalTree forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. forall a. a -> Maybe a
Just (forall record. Entity record -> Key record
entityKey Entity Tree
ent)]

loadHackageTreeKey ::
     P.PackageName
  -> P.Version
  -> SHA256
  -> ReaderT SqlBackend (RIO env) (Maybe TreeKey)
loadHackageTreeKey :: forall env.
PackageName
-> Version
-> SHA256
-> ReaderT SqlBackend (RIO env) (Maybe TreeKey)
loadHackageTreeKey PackageName
name Version
ver SHA256
sha = do
  [(Single SHA256, Single FileSize)]
res <- forall a (m :: * -> *) backend.
(RawSql a, MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m [a]
rawSql
    Text
"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"
    [ forall a. PersistField a => a -> PersistValue
toPersistValue forall a b. (a -> b) -> a -> b
$ PackageName -> PackageNameP
P.PackageNameP PackageName
name
    , forall a. PersistField a => a -> PersistValue
toPersistValue forall a b. (a -> b) -> a -> b
$ Version -> VersionP
P.VersionP Version
ver
    , forall a. PersistField a => a -> PersistValue
toPersistValue SHA256
sha
    ]
  case [(Single SHA256, Single FileSize)]
res of
    [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    (Single SHA256
treesha, Single FileSize
size):[(Single SHA256, Single FileSize)]
_ ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ BlobKey -> TreeKey
P.TreeKey forall a b. (a -> b) -> a -> b
$ SHA256 -> FileSize -> BlobKey
P.BlobKey SHA256
treesha FileSize
size

loadHackageTree ::
     (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => P.RawPackageLocationImmutable -- ^ for exceptions

  -> P.PackageName
  -> P.Version
  -> BlobId
  -> ReaderT SqlBackend (RIO env) (Maybe Package)
loadHackageTree :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> PackageName
-> Version
-> Key Blob
-> ReaderT SqlBackend (RIO env) (Maybe Package)
loadHackageTree RawPackageLocationImmutable
rpli PackageName
name Version
ver Key Blob
bid = do
  Key PackageName
nameid <- forall env.
PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
getPackageNameId PackageName
name
  Key Version
versionid <- forall env. Version -> ReaderT SqlBackend (RIO env) (Key Version)
getVersionId Version
ver
  Maybe (Entity HackageCabal)
ment <- forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m (Maybe (Entity record))
selectFirst
    [ forall typ. (typ ~ Key PackageName) => EntityField HackageCabal typ
HackageCabalName forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key PackageName
nameid
    , forall typ. (typ ~ Key Version) => EntityField HackageCabal typ
HackageCabalVersion forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key Version
versionid
    , forall typ. (typ ~ Key Blob) => EntityField HackageCabal typ
HackageCabalCabal forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key Blob
bid
    , forall typ.
(typ ~ Maybe (Key Tree)) =>
EntityField HackageCabal typ
HackageCabalTree forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
!=. forall a. Maybe a
Nothing
    ]
    []
  case Maybe (Entity HackageCabal)
ment of
    Maybe (Entity HackageCabal)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    Just (Entity Key HackageCabal
_ HackageCabal
hc) ->
      case HackageCabal -> Maybe (Key Tree)
hackageCabalTree HackageCabal
hc of
        Maybe (Key Tree)
Nothing -> forall a. HasCallStack => Bool -> a -> a
assert Bool
False forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        Just Key Tree
tid -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> Key Tree -> ReaderT SqlBackend (RIO env) Package
loadPackageById RawPackageLocationImmutable
rpli Key Tree
tid

storeArchiveCache ::
     Text -- ^ URL

  -> Text -- ^ subdir

  -> SHA256
  -> FileSize
  -> P.TreeKey
  -> ReaderT SqlBackend (RIO env) ()
storeArchiveCache :: forall env.
Text
-> Text
-> SHA256
-> FileSize
-> TreeKey
-> ReaderT SqlBackend (RIO env) ()
storeArchiveCache Text
url Text
subdir SHA256
sha FileSize
size TreeKey
treeKey' = do
  UTCTime
now <- forall (m :: * -> *). MonadIO m => m UTCTime
getCurrentTime
  Maybe (Entity Tree)
ment <- forall env.
TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
getTreeForKey TreeKey
treeKey'
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (Entity Tree)
ment forall a b. (a -> b) -> a -> b
$ \Entity Tree
ent -> forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m ()
insert_ ArchiveCache
    { archiveCacheTime :: UTCTime
archiveCacheTime = UTCTime
now
    , archiveCacheUrl :: Text
archiveCacheUrl = Text
url
    , archiveCacheSubdir :: Text
archiveCacheSubdir = Text
subdir
    , archiveCacheSha :: SHA256
archiveCacheSha = SHA256
sha
    , archiveCacheSize :: FileSize
archiveCacheSize = FileSize
size
    , archiveCacheTree :: Key Tree
archiveCacheTree = forall record. Entity record -> Key record
entityKey Entity Tree
ent
    }

loadArchiveCache ::
     Text -- ^ URL

  -> Text -- ^ subdir

  -> ReaderT SqlBackend (RIO env) [(SHA256, FileSize, TreeId)]
loadArchiveCache :: forall env.
Text
-> Text
-> ReaderT SqlBackend (RIO env) [(SHA256, FileSize, Key Tree)]
loadArchiveCache Text
url Text
subdir = forall a b. (a -> b) -> [a] -> [b]
map Entity ArchiveCache -> (SHA256, FileSize, Key Tree)
go forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Entity record]
selectList
  [ forall typ. (typ ~ Text) => EntityField ArchiveCache typ
ArchiveCacheUrl forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Text
url
  , forall typ. (typ ~ Text) => EntityField ArchiveCache typ
ArchiveCacheSubdir forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Text
subdir
  ]
  [forall record typ. EntityField record typ -> SelectOpt record
Desc forall typ. (typ ~ UTCTime) => EntityField ArchiveCache typ
ArchiveCacheTime]
 where
  go :: Entity ArchiveCache -> (SHA256, FileSize, Key Tree)
go (Entity Key ArchiveCache
_ ArchiveCache
ac) = (ArchiveCache -> SHA256
archiveCacheSha ArchiveCache
ac, ArchiveCache -> FileSize
archiveCacheSize ArchiveCache
ac, ArchiveCache -> Key Tree
archiveCacheTree ArchiveCache
ac)

storeRepoCache ::
     Repo
  -> Text -- ^ subdir

  -> TreeId
  -> ReaderT SqlBackend (RIO env) ()
storeRepoCache :: forall env.
Repo -> Text -> Key Tree -> ReaderT SqlBackend (RIO env) ()
storeRepoCache Repo
repo Text
subdir Key Tree
tid = do
  UTCTime
now <- forall (m :: * -> *). MonadIO m => m UTCTime
getCurrentTime
  forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m ()
insert_ RepoCache
    { repoCacheTime :: UTCTime
repoCacheTime = UTCTime
now
    , repoCacheUrl :: Text
repoCacheUrl = Repo -> Text
repoUrl Repo
repo
    , repoCacheType :: RepoType
repoCacheType = Repo -> RepoType
repoType Repo
repo
    , repoCacheCommit :: Text
repoCacheCommit = Repo -> Text
repoCommit Repo
repo
    , repoCacheSubdir :: Text
repoCacheSubdir = Text
subdir
    , repoCacheTree :: Key Tree
repoCacheTree = Key Tree
tid
    }

loadRepoCache ::
     Repo
  -> ReaderT SqlBackend (RIO env) (Maybe TreeId)
loadRepoCache :: forall env. Repo -> ReaderT SqlBackend (RIO env) (Maybe (Key Tree))
loadRepoCache Repo
repo = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RepoCache -> Key Tree
repoCacheTree forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall record. Entity record -> record
entityVal) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m (Maybe (Entity record))
selectFirst
  [ forall typ. (typ ~ Text) => EntityField RepoCache typ
RepoCacheUrl forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Repo -> Text
repoUrl Repo
repo
  , forall typ. (typ ~ RepoType) => EntityField RepoCache typ
RepoCacheType forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Repo -> RepoType
repoType Repo
repo
  , forall typ. (typ ~ Text) => EntityField RepoCache typ
RepoCacheCommit forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Repo -> Text
repoCommit Repo
repo
  , forall typ. (typ ~ Text) => EntityField RepoCache typ
RepoCacheSubdir forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Repo -> Text
repoSubdir Repo
repo
  ]
  [forall record typ. EntityField record typ -> SelectOpt record
Desc forall typ. (typ ~ UTCTime) => EntityField RepoCache typ
RepoCacheTime]

storePreferredVersion ::
     P.PackageName
  -> Text
  -> ReaderT SqlBackend (RIO env) ()
storePreferredVersion :: forall env. PackageName -> Text -> ReaderT SqlBackend (RIO env) ()
storePreferredVersion PackageName
name Text
p = do
  Key PackageName
nameid <- forall env.
PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
getPackageNameId PackageName
name
  Maybe (Entity PreferredVersions)
ment <- forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
getBy forall a b. (a -> b) -> a -> b
$ Key PackageName -> Unique PreferredVersions
UniquePreferred Key PackageName
nameid
  case Maybe (Entity PreferredVersions)
ment of
    Maybe (Entity PreferredVersions)
Nothing -> forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m ()
insert_ PreferredVersions
      { preferredVersionsName :: Key PackageName
preferredVersionsName = Key PackageName
nameid
      , preferredVersionsPreferred :: Text
preferredVersionsPreferred = Text
p
      }
    Just (Entity Key PreferredVersions
pid PreferredVersions
_) -> forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> [Update record] -> ReaderT backend m ()
update Key PreferredVersions
pid [forall typ. (typ ~ Text) => EntityField PreferredVersions typ
PreferredVersionsPreferred forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. Text
p]

loadPreferredVersion ::
     P.PackageName
  -> ReaderT SqlBackend (RIO env) (Maybe Text)
loadPreferredVersion :: forall env.
PackageName -> ReaderT SqlBackend (RIO env) (Maybe Text)
loadPreferredVersion PackageName
name = do
  Key PackageName
nameid <- forall env.
PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
getPackageNameId PackageName
name
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PreferredVersions -> Text
preferredVersionsPreferred forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall record. Entity record -> record
entityVal) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
getBy (Key PackageName -> Unique PreferredVersions
UniquePreferred Key PackageName
nameid)

sinkHackagePackageNames ::
     (P.PackageName -> Bool)
  -> ConduitT P.PackageName Void (ReaderT SqlBackend (RIO env)) a
  -> ReaderT SqlBackend (RIO env) a
sinkHackagePackageNames :: forall env a.
(PackageName -> Bool)
-> ConduitT PackageName Void (ReaderT SqlBackend (RIO env)) a
-> ReaderT SqlBackend (RIO env) a
sinkHackagePackageNames PackageName -> Bool
predicate ConduitT PackageName Void (ReaderT SqlBackend (RIO env)) a
sink = do
  Acquire
  (ConduitM
     () (Entity PackageName) (ReaderT SqlBackend (RIO env)) ())
acqSrc <- forall backend record (m1 :: * -> *) (m2 :: * -> *).
(PersistQueryRead backend, PersistRecordBackend record backend,
 MonadIO m1, MonadIO m2) =>
[Filter record]
-> [SelectOpt record]
-> ReaderT backend m1 (Acquire (ConduitM () (Entity record) m2 ()))
selectSourceRes [] []
  forall (m :: * -> *) a b.
MonadUnliftIO m =>
Acquire a -> (a -> m b) -> m b
with Acquire
  (ConduitM
     () (Entity PackageName) (ReaderT SqlBackend (RIO env)) ())
acqSrc forall a b. (a -> b) -> a -> b
$ \ConduitM () (Entity PackageName) (ReaderT SqlBackend (RIO env)) ()
src -> forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit
    forall a b. (a -> b) -> a -> b
$ ConduitM () (Entity PackageName) (ReaderT SqlBackend (RIO env)) ()
src
   forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) mono a.
(Monad m, MonoFoldable mono) =>
(a -> m mono) -> ConduitT a (Element mono) m ()
concatMapMC Entity PackageName
-> ReaderT SqlBackend (RIO env) (Maybe PackageName)
go
   forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT PackageName Void (ReaderT SqlBackend (RIO env)) a
sink
 where
  go :: Entity PackageName
-> ReaderT SqlBackend (RIO env) (Maybe PackageName)
go (Entity Key PackageName
nameid (PackageName (PackageNameP PackageName
name)))
    | PackageName -> Bool
predicate PackageName
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.

        Bool
onHackage <- forall {backend} {m :: * -> *}.
(BaseBackend backend ~ SqlBackend, MonadIO m,
 PersistQueryRead backend) =>
Key PackageName -> ReaderT backend m Bool
checkOnHackage Key PackageName
nameid
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if Bool
onHackage then forall a. a -> Maybe a
Just PackageName
name else forall a. Maybe a
Nothing
    | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

  checkOnHackage :: Key PackageName -> ReaderT backend m Bool
checkOnHackage Key PackageName
nameid = do
    Int
cnt <- forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m Int
count [forall typ. (typ ~ Key PackageName) => EntityField HackageCabal typ
HackageCabalName forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key PackageName
nameid]
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Int
cnt forall a. Ord a => a -> a -> Bool
> Int
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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir -> RIO env (PackageName, Path Abs File)
findOrGenerateCabalFile Path Abs Dir
pkgDir = do
  forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir -> RIO env ()
hpack Path Abs Dir
pkgDir
  [Path Abs File]
files <- forall a. (a -> Bool) -> [a] -> [a]
filter (forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> String -> Bool
hasExtension String
"cabal" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> String
toFilePath) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd
       forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
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 :: String -> Bool
isHidden (Char
'.':String
_) = Bool
True
      isHidden String
_ = Bool
False
  case forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isHidden forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Rel File -> String
fromRelFile forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. Path b File -> Path Rel File
filename) [Path Abs File]
files of
    [] -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> PantryException
P.NoCabalFileFound Path Abs Dir
pkgDir
    [Path Abs File
x] -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      (forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Path Abs File -> PantryException
P.InvalidCabalFilePath Path Abs File
x)
      (\PackageName
pn -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageName
pn, Path Abs File
x)) forall a b. (a -> b) -> a -> b
$
        forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripSuffix String
".cabal" (forall b t. Path b t -> String
toFilePath (forall b. Path b File -> Path Rel File
filename Path Abs File
x)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        String -> Maybe PackageName
P.parsePackageName
    Path Abs File
_:[Path Abs File]
_ -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> [Path Abs File] -> PantryException
P.MultipleCabalFilesFound Path Abs Dir
pkgDir [Path Abs File]
files
 where
  hasExtension :: String -> String -> Bool
hasExtension String
fp String
x = ShowS
FilePath.takeExtension String
fp forall a. Eq a => a -> a -> Bool
== String
"." forall a. [a] -> [a] -> [a]
++ String
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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> Tree -> ReaderT SqlBackend (RIO env) (PackageName, ByteString)
hpackToCabalS RawPackageLocationImmutable
rpli Tree
tree = do
  Path Abs Dir
tmpDir <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ do
    Path Abs Dir
tdir <- forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getTempDir
    forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> String -> m (Path Abs Dir)
createTempDir Path Abs Dir
tdir String
"hpack-pkg-dir"
  forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawPackageLocationImmutable
-> Path Abs Dir -> Tree -> ReaderT SqlBackend (RIO env) ()
unpackTreeToDir RawPackageLocationImmutable
rpli Path Abs Dir
tmpDir Tree
tree
  (PackageName
packageName, Path Abs File
cfile) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir -> RIO env (PackageName, Path Abs File)
findOrGenerateCabalFile Path Abs Dir
tmpDir
  !ByteString
bs <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => String -> m ByteString
B.readFile (Path Abs File -> String
fromAbsFile Path Abs File
cfile)
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
removeDirRecur Path Abs Dir
tmpDir
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageName
packageName, ByteString
bs)

hpackToCabal ::
     (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => P.RawPackageLocationImmutable -- ^ for exceptions

  -> P.Tree
  -> RIO env (P.PackageName, ByteString)
hpackToCabal :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> Tree -> RIO env (PackageName, ByteString)
hpackToCabal RawPackageLocationImmutable
rpli Tree
tree = forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> (String -> m a) -> m a
withSystemTempDirectory String
"hpack-pkg-dir" forall a b. (a -> b) -> a -> b
$ \String
tmpdir -> do
  Path Abs Dir
tdir <- forall (m :: * -> *). MonadThrow m => String -> m (Path Abs Dir)
parseAbsDir String
tmpdir
  forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage forall a b. (a -> b) -> a -> b
$ forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawPackageLocationImmutable
-> Path Abs Dir -> Tree -> ReaderT SqlBackend (RIO env) ()
unpackTreeToDir RawPackageLocationImmutable
rpli Path Abs Dir
tdir Tree
tree
  (PackageName
packageName, Path Abs File
cfile) <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir -> RIO env (PackageName, Path Abs File)
findOrGenerateCabalFile Path Abs Dir
tdir
  ByteString
bs <- forall (m :: * -> *). MonadIO m => String -> m ByteString
B.readFile (Path Abs File -> String
fromAbsFile Path Abs File
cfile)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageName
packageName, ByteString
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 :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawPackageLocationImmutable
-> Path Abs Dir -> Tree -> ReaderT SqlBackend (RIO env) ()
unpackTreeToDir RawPackageLocationImmutable
rpli (forall b t. Path b t -> String
toFilePath -> String
dir) (P.TreeMap Map SafeFilePath TreeEntry
m) = do
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_  (forall k a. Map k a -> [(k, a)]
Map.toList Map SafeFilePath TreeEntry
m) forall a b. (a -> b) -> a -> b
$ \(SafeFilePath
sfp, P.TreeEntry BlobKey
blobKey FileType
ft) -> do
    let dest :: String
dest = String
dir String -> ShowS
</> Text -> String
T.unpack (SafeFilePath -> Text
P.unSafeFilePath SafeFilePath
sfp)
    forall (m :: * -> *). MonadIO m => Bool -> String -> m ()
createDirectoryIfMissing Bool
True forall a b. (a -> b) -> a -> b
$ ShowS
takeDirectory String
dest
    Maybe ByteString
mbs <- forall env.
HasLogFunc env =>
BlobKey -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
loadBlob BlobKey
blobKey
    case Maybe ByteString
mbs of
      Maybe ByteString
Nothing -> do
        -- TODO when we have pantry wire stuff, try downloading

        forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable
-> SafeFilePath -> BlobKey -> PantryException
P.TreeReferencesMissingBlob RawPackageLocationImmutable
rpli SafeFilePath
sfp BlobKey
blobKey
      Just ByteString
bs -> do
        forall (m :: * -> *). MonadIO m => String -> ByteString -> m ()
B.writeFile String
dest ByteString
bs
        case FileType
ft of
          FileType
FTNormal -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          FileType
FTExecutable -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
            Permissions
perms <- forall (m :: * -> *). MonadIO m => String -> m Permissions
getPermissions String
dest
            forall (m :: * -> *). MonadIO m => String -> Permissions -> m ()
setPermissions String
dest forall a b. (a -> b) -> a -> b
$ Bool -> Permissions -> Permissions
setOwnerExecutable Bool
True Permissions
perms

countHackageCabals :: ReaderT SqlBackend (RIO env) Int
countHackageCabals :: forall env. ReaderT SqlBackend (RIO env) Int
countHackageCabals = do
  [Single Int]
res <- forall a (m :: * -> *) backend.
(RawSql a, MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m [a]
rawSql
    Text
"SELECT COUNT(*)\n\
    \FROM hackage_cabal"
    []
  case [Single Int]
res of
    [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0
    (Single Int
n):[Single Int]
_ ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
n

getSnapshotCacheByHash ::
     SnapshotCacheHash
  -> ReaderT SqlBackend (RIO env) (Maybe SnapshotCacheId)
getSnapshotCacheByHash :: forall env.
SnapshotCacheHash
-> ReaderT SqlBackend (RIO env) (Maybe (Key SnapshotCache))
getSnapshotCacheByHash =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall record. Entity record -> Key record
entityKey) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
getBy forall b c a. (b -> c) -> (a -> b) -> a -> c
. SHA256 -> Unique SnapshotCache
UniqueSnapshotCache forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapshotCacheHash -> SHA256
unSnapshotCacheHash

getSnapshotCacheId ::
     SnapshotCacheHash
  -> ReaderT SqlBackend (RIO env) SnapshotCacheId
getSnapshotCacheId :: forall env.
SnapshotCacheHash
-> ReaderT SqlBackend (RIO env) (Key SnapshotCache)
getSnapshotCacheId =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall record. Entity record -> Key record
entityKey forall a. a -> a
id) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall record backend (m :: * -> *).
(MonadIO m, PersistUniqueWrite backend,
 PersistRecordBackend record backend, AtLeastOneUniqueKey record,
 SafeToInsert record) =>
record -> ReaderT backend m (Either (Entity record) (Key record))
insertBy forall b c a. (b -> c) -> (a -> b) -> a -> c
. SHA256 -> SnapshotCache
SnapshotCache forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapshotCacheHash -> SHA256
unSnapshotCacheHash

getModuleNameId ::
     P.ModuleName
  -> ReaderT SqlBackend (RIO env) ModuleNameId
getModuleNameId :: forall env.
ModuleName -> ReaderT SqlBackend (RIO env) (Key ModuleName)
getModuleNameId =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall record. Entity record -> Key record
entityKey forall a. a -> a
id) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall record backend (m :: * -> *).
(MonadIO m, PersistUniqueWrite backend,
 PersistRecordBackend record backend, AtLeastOneUniqueKey record,
 SafeToInsert record) =>
record -> ReaderT backend m (Either (Entity record) (Key record))
insertBy forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleNameP -> ModuleName
ModuleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> ModuleNameP
P.ModuleNameP

storeSnapshotModuleCache ::
     SnapshotCacheId
  -> Map P.PackageName (Set P.ModuleName)
  -> ReaderT SqlBackend (RIO env) ()
storeSnapshotModuleCache :: forall env.
Key SnapshotCache
-> Map PackageName (Set ModuleName)
-> ReaderT SqlBackend (RIO env) ()
storeSnapshotModuleCache Key SnapshotCache
cache Map PackageName (Set ModuleName)
packageModules =
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName (Set ModuleName)
packageModules) forall a b. (a -> b) -> a -> b
$ \(PackageName
pn, Set ModuleName
modules) -> do
    Key PackageName
package <- forall env.
PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
getPackageNameId PackageName
pn
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Set ModuleName
modules forall a b. (a -> b) -> a -> b
$ \ModuleName
m -> do
      Key ModuleName
moduleName <- forall env.
ModuleName -> ReaderT SqlBackend (RIO env) (Key ModuleName)
getModuleNameId ModuleName
m
      forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m ()
insert_ PackageExposedModule
        { packageExposedModuleSnapshotCache :: Key SnapshotCache
packageExposedModuleSnapshotCache = Key SnapshotCache
cache
        , packageExposedModulePackage :: Key PackageName
packageExposedModulePackage = Key PackageName
package
        , packageExposedModuleModule :: Key ModuleName
packageExposedModuleModule = Key ModuleName
moduleName
        }

loadExposedModulePackages ::
     SnapshotCacheId
  -> P.ModuleName
  -> ReaderT SqlBackend (RIO env) [P.PackageName]
loadExposedModulePackages :: forall env.
Key SnapshotCache
-> ModuleName -> ReaderT SqlBackend (RIO env) [PackageName]
loadExposedModulePackages Key SnapshotCache
cacheId ModuleName
mName =
  forall a b. (a -> b) -> [a] -> [b]
map Single PackageNameP -> PackageName
go forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *) backend.
(RawSql a, MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m [a]
rawSql
    Text
"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"
    [ forall a. PersistField a => a -> PersistValue
toPersistValue (ModuleName -> ModuleNameP
P.ModuleNameP ModuleName
mName)
    , forall a. PersistField a => a -> PersistValue
toPersistValue Key SnapshotCache
cacheId
    ]
 where
  go :: Single PackageNameP -> PackageName
go (Single (P.PackageNameP PackageName
m)) = PackageName
m

newtype LoadCachedTreeException = MissingBlob BlobKey
  deriving (Int -> LoadCachedTreeException -> ShowS
[LoadCachedTreeException] -> ShowS
LoadCachedTreeException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LoadCachedTreeException] -> ShowS
$cshowList :: [LoadCachedTreeException] -> ShowS
show :: LoadCachedTreeException -> String
$cshow :: LoadCachedTreeException -> String
showsPrec :: Int -> LoadCachedTreeException -> ShowS
$cshowsPrec :: Int -> LoadCachedTreeException -> ShowS
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 :: forall env.
Tree
-> ReaderT
     SqlBackend (RIO env) (Either LoadCachedTreeException CachedTree)
loadCachedTree (P.TreeMap Map SafeFilePath TreeEntry
m) =
  forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try forall a b. (a -> b) -> a -> b
$ Map SafeFilePath (TreeEntry, Key Blob) -> CachedTree
CachedTreeMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TreeEntry -> ReaderT SqlBackend (RIO env) (TreeEntry, Key Blob)
loadEntry Map SafeFilePath TreeEntry
m
 where
  loadEntry :: P.TreeEntry -> ReaderT SqlBackend (RIO env) (P.TreeEntry, BlobId)
  loadEntry :: TreeEntry -> ReaderT SqlBackend (RIO env) (TreeEntry, Key Blob)
loadEntry TreeEntry
te = (TreeEntry
te, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlobKey -> ReaderT SqlBackend (RIO env) (Key Blob)
loadBlob' (TreeEntry -> BlobKey
P.teBlob TreeEntry
te)

  loadBlob' :: BlobKey -> ReaderT SqlBackend (RIO env) BlobId
  loadBlob' :: BlobKey -> ReaderT SqlBackend (RIO env) (Key Blob)
loadBlob' blobKey :: BlobKey
blobKey@(P.BlobKey SHA256
sha FileSize
_) = do
    Maybe (Key Blob)
mbid <- forall env.
SHA256 -> ReaderT SqlBackend (RIO env) (Maybe (Key Blob))
loadBlobBySHA SHA256
sha
    case Maybe (Key Blob)
mbid of
      Maybe (Key Blob)
Nothing -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ BlobKey -> LoadCachedTreeException
MissingBlob BlobKey
blobKey
      Just Key Blob
bid -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Key Blob
bid