{-# LANGUAGE NoImplicitPrelude          #-}
{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TupleSections              #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE UndecidableInstances       #-}
{-# LANGUAGE ViewPatterns               #-}

module Pantry.Storage
  ( SqlBackend
  , initStorage
  , withStorage
  , migrateAll
  , storeBlob
  , loadBlob
  , loadBlobById
  , loadBlobBySHA
  , allBlobsSource
  , allHackageCabalRawPackageLocations
  , allBlobsCount
  , allHackageCabalCount
  , getBlobKey
  , loadURLBlob
  , storeURLBlob
  , clearHackageRevisions
  , storeHackageRevision
  , loadHackagePackageVersions
  , loadHackagePackageVersion
  , loadLatestCacheUpdate
  , storeCacheUpdate
  , storeHackageTarballInfo
  , loadHackageTarballInfo
  , getHPackBlobKeyById
  , storeTree
  , loadTree
  , storeHPack
  , loadPackageById
  , getPackageNameById
  , getPackageNameId
  , getVersionId
  , getTreeForKey
  , storeHackageTree
  , loadHackageTree
  , loadHackageTreeKey
  , storeArchiveCache
  , loadArchiveCache
  , storeRepoCache
  , loadRepoCache
  , storePreferredVersion
  , loadPreferredVersion
  , sinkHackagePackageNames
  , loadCabalBlobKey
  , hpackToCabal
  , countHackageCabals
  , getSnapshotCacheByHash
  , getSnapshotCacheId
  , storeSnapshotModuleCache
  , loadExposedModulePackages
  , findOrGenerateCabalFile
  , PackageNameId
  , PackageName
  , VersionId
  , ModuleNameId
  , Version
  , versionVersion
  , Unique(..)
  , EntityField(..)
    -- avoid warnings

  , BlobId
  , Key(unBlobKey)
  , HackageCabalId
  , HackageCabal(..)
  , HackageTarballId
  , CacheUpdateId
  , FilePathId
  , Tree(..)
  , TreeId
  , TreeEntry(..)
  , TreeEntryId
  , ArchiveCacheId
  , RepoCacheId
  , PreferredVersionsId
  , UrlBlobId
  , SnapshotCacheId
  , PackageExposedModuleId
  , loadCachedTree
  , CachedTree (..)
  , unCachedTree
  ) where

import           Conduit ( ConduitT, (.|), concatMapMC, mapC, runConduit )
import           Data.Acquire ( with )
import           Database.Persist ( ( !=.), (=.), (==.), (>.) )
import           Database.Persist.Class.PersistEntity
                   ( Entity (..), EntityField, Filter (..), Key, SelectOpt (..)
                   , Unique
                   )
import           Database.Persist.Class.PersistField ( PersistField (..) )
import           Database.Persist.Class.PersistQuery
                   ( count, deleteWhere, selectFirst, selectKeysList, selectList
                   , selectSource, selectSourceRes, updateWhere
                   )
import           Database.Persist.Class.PersistStore
                   ( get, getJust, insert, insert_, update,  )
import           Database.Persist.Class.PersistUnique ( getBy, insertBy )
import           Database.Persist.Sql ( Single (..), rawExecute, rawSql )
import           Database.Persist.SqlBackend ( SqlBackend )
import           Database.Persist.TH
                   ( mkMigrate, mkPersist, persistLowerCase, share, sqlSettings
                   )
import           Pantry.HPack ( hpack, hpackVersion )
import qualified Pantry.SHA256 as SHA256
import qualified Pantry.SQLite as SQLite
import           Pantry.Types
                   ( BlobKey, FileSize (..), FileType (..), HasPantryConfig
                   , Package (..), PackageNameP (..), Repo (..), Revision (..)
                   , SHA256, SafeFilePath, SnapshotCacheHash (..), TreeKey
                   , VersionP (..), connRDBMS
                   )
import qualified Pantry.Types as P
import           Path
                   ( Abs, Dir, File, Path, filename, fromAbsFile, fromRelFile
                   , parseAbsDir, toFilePath
                   )
import           Path.IO ( createTempDir, getTempDir, listDir, removeDirRecur )
import           RIO hiding ( FilePath )
import qualified RIO.ByteString as B
import           RIO.Directory
                   ( createDirectoryIfMissing, getPermissions
                   , setOwnerExecutable, setPermissions
                   )
import           RIO.FilePath ( (</>), takeDirectory )
import qualified RIO.FilePath as FilePath
import qualified RIO.List as List
import qualified RIO.Map as Map
import           RIO.Orphans ( HasResourceMap )
import           RIO.Process ( HasProcessContext )
import qualified RIO.Text as T
import           RIO.Time ( UTCTime, getCurrentTime )

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
-- Raw blobs
Blob
    sha SHA256
    size FileSize
    contents ByteString
    UniqueBlobSha sha
-- Previously downloaded blobs from given URLs.
-- May change over time, so we keep a time column too.
UrlBlob sql=url_blob
    url Text
    blob BlobId
    time UTCTime
    UniqueUrlTime url time

-- For normalization, and avoiding storing strings in a bunch of
-- tables.
PackageName
    name P.PackageNameP
    UniquePackageName name
Version
    version P.VersionP
    UniqueVersion version
FilePath
    path P.SafeFilePath
    UniqueSfp path

-- Secure download information for a package on Hackage. This does not
-- contain revision information, since sdist tarballs are (blessedly)
-- unmodified on Hackage.
HackageTarball
    name PackageNameId
    version VersionId
    sha SHA256
    size FileSize
    UniqueHackageTarball name version

-- An individual cabal file from Hackage, representing a specific
-- revision.
HackageCabal
    name PackageNameId
    version VersionId
    revision P.Revision
    cabal BlobId

    -- If available: the full tree containing the HackageTarball
    -- contents with the cabal file modified.
    tree TreeId Maybe
    UniqueHackage name version revision

-- Any preferred-version information from Hackage
PreferredVersions
    name PackageNameId
    preferred Text
    UniquePreferred name

-- Last time we downloaded a 01-index.tar file from Hackage and
-- updated the three previous tables.
CacheUpdate
    -- When did we do the update?
    time UTCTime

    -- How big was the file when we updated, ignoring the last two
    -- all-null 512-byte blocks.
    size FileSize

    -- SHA256 of the first 'size' bytes of the file
    sha SHA256

-- A tree containing a Haskell package. See associated TreeEntry
-- table.
Tree
    key BlobId

    -- If the treeCabal field is Nothing, it means the Haskell package
    -- doesn't have a corresponding cabal file for it. This may be the case
    -- for haskell package referenced by git repository with only a hpack file.
    cabal BlobId Maybe
    cabalType FileType
    name PackageNameId
    version VersionId
    UniqueTree key

HPack
   tree TreeId

   -- hpack version used for generating this cabal file
   version VersionId

   -- Generated cabal file for the given tree and hpack version
   cabalBlob BlobId
   cabalPath FilePathId

   UniqueHPack tree version

-- An individual file within a Tree.
TreeEntry
    tree TreeId
    path FilePathId
    blob BlobId
    type FileType

-- Like UrlBlob, but stores the contents as a Tree.
ArchiveCache
    time UTCTime
    url Text
    subdir Text
    sha SHA256
    size FileSize
    tree TreeId

-- Like ArchiveCache, but for a Repo.
RepoCache
    time UTCTime
    url Text
    type P.RepoType
    commit Text
    subdir Text
    tree TreeId

-- Identified by sha of all immutable packages contained in a snapshot
-- and GHC version used
SnapshotCache
    sha SHA256
    UniqueSnapshotCache sha

PackageExposedModule
    snapshotCache SnapshotCacheId
    module ModuleNameId
    package PackageNameId

ModuleName
    name P.ModuleNameP
    UniqueModule name
|]

initStorage ::
     HasLogFunc env
  => Path Abs File -- ^ storage file

  -> (P.Storage -> RIO env a)
  -> RIO env a
initStorage :: forall env a.
HasLogFunc env =>
Path Abs File -> (Storage -> RIO env a) -> RIO env a
initStorage =
  Text
-> Migration
-> Path Abs File
-> (Storage -> RIO env a)
-> RIO env a
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 <- Getting Storage env Storage -> RIO env Storage
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((PantryConfig -> Const Storage PantryConfig)
-> env -> Const Storage env
forall env. HasPantryConfig env => Lens' env PantryConfig
Lens' env PantryConfig
P.pantryConfigL((PantryConfig -> Const Storage PantryConfig)
 -> env -> Const Storage env)
-> ((Storage -> Const Storage Storage)
    -> PantryConfig -> Const Storage PantryConfig)
-> Getting Storage env Storage
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PantryConfig -> Storage) -> SimpleGetter PantryConfig Storage
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 :: forall env a. RdbmsActions env a -> ReaderT SqlBackend (RIO env) a
raSqlite :: ReaderT SqlBackend (RIO env) a
raSqlite, ReaderT SqlBackend (RIO env) a
raPostgres :: forall env a. RdbmsActions env a -> ReaderT SqlBackend (RIO env) a
raPostgres :: ReaderT SqlBackend (RIO env) a
raPostgres} = do
  Text
rdbms <- SqlBackend -> Text
Pantry.Types.connRDBMS (SqlBackend -> Text)
-> ReaderT SqlBackend (RIO env) SqlBackend
-> ReaderT SqlBackend (RIO env) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT SqlBackend (RIO env) SqlBackend
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
_ -> String -> ReaderT SqlBackend (RIO env) a
forall a. HasCallStack => String -> a
error (String -> ReaderT SqlBackend (RIO env) a)
-> String -> ReaderT SqlBackend (RIO env) a
forall a b. (a -> b) -> a -> b
$ String
"rdbmsAwareQuery: unsupported rdbms '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
rdbms String -> ShowS
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 = (Maybe PackageName -> Maybe PackageName)
-> ReaderT SqlBackend (RIO env) (Maybe PackageName)
-> ReaderT SqlBackend (RIO env) (Maybe PackageName)
forall a b.
(a -> b)
-> ReaderT SqlBackend (RIO env) a -> ReaderT SqlBackend (RIO env) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PackageNameP -> PackageName
unPackageNameP (PackageNameP -> PackageName)
-> (PackageName -> PackageNameP) -> PackageName -> PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> PackageNameP
packageNameName (PackageName -> PackageName)
-> Maybe PackageName -> Maybe PackageName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (ReaderT SqlBackend (RIO env) (Maybe PackageName)
 -> ReaderT SqlBackend (RIO env) (Maybe PackageName))
-> (Key PackageName
    -> ReaderT SqlBackend (RIO env) (Maybe PackageName))
-> Key PackageName
-> ReaderT SqlBackend (RIO env) (Maybe PackageName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key PackageName -> ReaderT SqlBackend (RIO env) (Maybe PackageName)
forall backend record (m :: * -> *).
(PersistStoreRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Key record -> ReaderT SqlBackend m (Maybe record)
get

getPackageNameId ::
     P.PackageName
  -> ReaderT SqlBackend (RIO env) PackageNameId
getPackageNameId :: forall env.
PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
getPackageNameId =
  (Either (Entity PackageName) (Key PackageName) -> Key PackageName)
-> ReaderT
     SqlBackend
     (RIO env)
     (Either (Entity PackageName) (Key PackageName))
-> ReaderT SqlBackend (RIO env) (Key PackageName)
forall a b.
(a -> b)
-> ReaderT SqlBackend (RIO env) a -> ReaderT SqlBackend (RIO env) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Entity PackageName -> Key PackageName)
-> (Key PackageName -> Key PackageName)
-> Either (Entity PackageName) (Key PackageName)
-> Key PackageName
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Entity PackageName -> Key PackageName
forall record. Entity record -> Key record
entityKey Key PackageName -> Key PackageName
forall a. a -> a
id) (ReaderT
   SqlBackend
   (RIO env)
   (Either (Entity PackageName) (Key PackageName))
 -> ReaderT SqlBackend (RIO env) (Key PackageName))
-> (PackageName
    -> ReaderT
         SqlBackend
         (RIO env)
         (Either (Entity PackageName) (Key PackageName)))
-> PackageName
-> ReaderT SqlBackend (RIO env) (Key PackageName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName
-> ReaderT
     SqlBackend
     (RIO env)
     (Either (Entity PackageName) (Key PackageName))
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 (PackageName
 -> ReaderT
      SqlBackend
      (RIO env)
      (Either (Entity PackageName) (Key PackageName)))
-> (PackageName -> PackageName)
-> PackageName
-> ReaderT
     SqlBackend
     (RIO env)
     (Either (Entity PackageName) (Key PackageName))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageNameP -> PackageName
PackageName (PackageNameP -> PackageName)
-> (PackageName -> 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 = (Either (Entity Version) (Key Version) -> Key Version)
-> ReaderT
     SqlBackend (RIO env) (Either (Entity Version) (Key Version))
-> ReaderT SqlBackend (RIO env) (Key Version)
forall a b.
(a -> b)
-> ReaderT SqlBackend (RIO env) a -> ReaderT SqlBackend (RIO env) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Entity Version -> Key Version)
-> (Key Version -> Key Version)
-> Either (Entity Version) (Key Version)
-> Key Version
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Entity Version -> Key Version
forall record. Entity record -> Key record
entityKey Key Version -> Key Version
forall a. a -> a
id) (ReaderT
   SqlBackend (RIO env) (Either (Entity Version) (Key Version))
 -> ReaderT SqlBackend (RIO env) (Key Version))
-> (Version
    -> ReaderT
         SqlBackend (RIO env) (Either (Entity Version) (Key Version)))
-> Version
-> ReaderT SqlBackend (RIO env) (Key Version)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version
-> ReaderT
     SqlBackend (RIO env) (Either (Entity Version) (Key Version))
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 (Version
 -> ReaderT
      SqlBackend (RIO env) (Either (Entity Version) (Key Version)))
-> (Version -> Version)
-> Version
-> ReaderT
     SqlBackend (RIO env) (Either (Entity Version) (Key Version))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VersionP -> Version
Version (VersionP -> Version)
-> (Version -> 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 (Word -> FileSize) -> Word -> FileSize
forall a b. (a -> b) -> a -> b
$ Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> Int -> Word
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length ByteString
bs
  [Key Blob]
keys <- [Filter Blob]
-> [SelectOpt Blob] -> ReaderT SqlBackend (RIO env) [Key Blob]
forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Key record]
selectKeysList [EntityField Blob SHA256
forall typ. (typ ~ SHA256) => EntityField Blob typ
BlobSha EntityField Blob SHA256 -> SHA256 -> Filter Blob
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. SHA256
sha] []
  Key Blob
key <-
    case [Key Blob]
keys of
      [] ->
        RdbmsActions env (Key Blob)
-> ReaderT SqlBackend (RIO env) (Key Blob)
forall env a. RdbmsActions env a -> ReaderT SqlBackend (RIO env) a
rdbmsAwareQuery
          RdbmsActions
            { raSqlite :: ReaderT SqlBackend (RIO env) (Key Blob)
raSqlite =
                Blob -> ReaderT SqlBackend (RIO env) (Key Blob)
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m (Key record)
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend,
 SafeToInsert record) =>
record -> ReaderT SqlBackend 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
                Text -> [PersistValue] -> ReaderT SqlBackend (RIO env) ()
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"
                  [ SHA256 -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue SHA256
sha
                  , FileSize -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue FileSize
size
                  , ByteString -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue ByteString
bs
                  ]
                Text
-> [PersistValue]
-> ReaderT SqlBackend (RIO env) [Single (Key Blob)]
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 = ?"
                  [SHA256 -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue SHA256
sha] ReaderT SqlBackend (RIO env) [Single (Key Blob)]
-> ([Single (Key Blob)] -> ReaderT SqlBackend (RIO env) (Key Blob))
-> ReaderT SqlBackend (RIO env) (Key Blob)
forall a b.
ReaderT SqlBackend (RIO env) a
-> (a -> ReaderT SqlBackend (RIO env) b)
-> ReaderT SqlBackend (RIO env) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  [Single Key Blob
key] -> Key Blob -> ReaderT SqlBackend (RIO env) (Key Blob)
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Key Blob
key
                  [Single (Key Blob)]
_ -> String -> ReaderT SqlBackend (RIO env) (Key Blob)
forall a. HasCallStack => String -> a
error
                    String
"soreBlob: there was a critical problem storing a blob."
            }
      Key Blob
key:[Key Blob]
rest -> Bool
-> ReaderT SqlBackend (RIO env) (Key Blob)
-> ReaderT SqlBackend (RIO env) (Key Blob)
forall a. HasCallStack => Bool -> a -> a
assert ([Key Blob] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Key Blob]
rest) (Key Blob -> ReaderT SqlBackend (RIO env) (Key Blob)
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Key Blob
key)
  (Key Blob, BlobKey)
-> ReaderT SqlBackend (RIO env) (Key Blob, BlobKey)
forall a. a -> ReaderT SqlBackend (RIO env) a
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 <- Unique Blob -> ReaderT SqlBackend (RIO env) (Maybe (Entity Blob))
forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Unique record -> ReaderT SqlBackend m (Maybe (Entity record))
getBy (Unique Blob -> ReaderT SqlBackend (RIO env) (Maybe (Entity Blob)))
-> Unique Blob
-> ReaderT SqlBackend (RIO env) (Maybe (Entity Blob))
forall a b. (a -> b) -> a -> b
$ SHA256 -> Unique Blob
UniqueBlobSha SHA256
sha
  case Maybe (Entity Blob)
ment of
    Maybe (Entity Blob)
Nothing -> Maybe ByteString -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
forall a. Maybe a
Nothing
    Just (Entity Key Blob
_ Blob
bt)
      | Blob -> FileSize
blobSize Blob
bt FileSize -> FileSize -> Bool
forall a. Eq a => a -> a -> Bool
== FileSize
size -> Maybe ByteString -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString
 -> ReaderT SqlBackend (RIO env) (Maybe ByteString))
-> Maybe ByteString
-> ReaderT SqlBackend (RIO env) (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Blob -> ByteString
blobContents Blob
bt
      | Bool
otherwise ->
          Maybe ByteString
forall a. Maybe a
Nothing Maybe ByteString
-> ReaderT SqlBackend (RIO env) ()
-> ReaderT SqlBackend (RIO env) (Maybe ByteString)
forall a b.
a
-> ReaderT SqlBackend (RIO env) b -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ RIO env () -> ReaderT SqlBackend (RIO env) ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT SqlBackend m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
             Utf8Builder
"Mismatched blob size detected for SHA " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> SHA256 -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display SHA256
sha Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
             Utf8Builder
". Expected size: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> FileSize -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display FileSize
size Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
             Utf8Builder
". Actual size: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> FileSize -> Utf8Builder
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 = [Key Blob] -> Maybe (Key Blob)
forall a. [a] -> Maybe a
listToMaybe ([Key Blob] -> Maybe (Key Blob))
-> ReaderT SqlBackend (RIO env) [Key Blob]
-> ReaderT SqlBackend (RIO env) (Maybe (Key Blob))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Filter Blob]
-> [SelectOpt Blob] -> ReaderT SqlBackend (RIO env) [Key Blob]
forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Key record]
selectKeysList [EntityField Blob SHA256
forall typ. (typ ~ SHA256) => EntityField Blob typ
BlobSha EntityField Blob SHA256 -> SHA256 -> Filter Blob
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 <- Key Blob -> ReaderT SqlBackend (RIO env) (Maybe Blob)
forall backend record (m :: * -> *).
(PersistStoreRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Key record -> ReaderT SqlBackend m (Maybe record)
get Key Blob
bid
  case Maybe Blob
mbt of
    Maybe Blob
Nothing -> String -> ReaderT SqlBackend (RIO env) ByteString
forall a. HasCallStack => String -> a
error String
"loadBlobById: ID doesn't exist in database"
    Just Blob
bt -> ByteString -> ReaderT SqlBackend (RIO env) ByteString
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> ReaderT SqlBackend (RIO env) ByteString)
-> ByteString -> ReaderT SqlBackend (RIO env) ByteString
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 =
  [Filter Blob]
-> [SelectOpt Blob]
-> ConduitM () (Entity Blob) (ReaderT SqlBackend (RIO env)) ()
forall record backend (m :: * -> *).
(PersistQueryRead backend, MonadResource m,
 PersistRecordBackend record backend, MonadReader backend m) =>
[Filter record]
-> [SelectOpt record] -> ConduitM () (Entity record) m ()
selectSource [EntityField Blob (Key Blob)
forall typ. (typ ~ Key Blob) => EntityField Blob typ
BlobId EntityField Blob (Key Blob) -> Key Blob -> Filter Blob
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
>. Key Blob
blobId | Just Key Blob
blobId <- [Maybe (Key Blob)
mblobId]] [EntityField Blob (Key Blob) -> SelectOpt Blob
forall record typ. EntityField record typ -> SelectOpt record
Asc EntityField Blob (Key Blob)
forall typ. (typ ~ Key Blob) => EntityField Blob typ
BlobId] ConduitM () (Entity Blob) (ReaderT SqlBackend (RIO env)) ()
-> ConduitT
     (Entity Blob)
     (Key Blob, ByteString)
     (ReaderT SqlBackend (RIO env))
     ()
-> ConduitT
     () (Key Blob, ByteString) (ReaderT SqlBackend (RIO env)) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.|
  (Entity Blob -> (Key Blob, ByteString))
-> ConduitT
     (Entity Blob)
     (Key Blob, ByteString)
     (ReaderT SqlBackend (RIO env))
     ()
forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
mapC (Entity Blob -> Key Blob
forall record. Entity record -> Key record
entityKey (Entity Blob -> Key Blob)
-> (Entity Blob -> ByteString)
-> Entity Blob
-> (Key Blob, ByteString)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Blob -> ByteString
blobContents (Blob -> ByteString)
-> (Entity Blob -> Blob) -> Entity Blob -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity Blob -> Blob
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 <-
    [Filter HackageCabal]
-> [SelectOpt HackageCabal]
-> ReaderT
     SqlBackend (RIO env) (Map (Key HackageCabal) 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
      [EntityField HackageCabal (Key HackageCabal)
forall typ.
(typ ~ Key HackageCabal) =>
EntityField HackageCabal typ
HackageCabalId EntityField HackageCabal (Key HackageCabal)
-> Key HackageCabal -> Filter HackageCabal
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 <- [Filter PackageName]
-> [SelectOpt PackageName]
-> ReaderT SqlBackend (RIO env) (Map (Key PackageName) 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 <- [Filter Version]
-> [SelectOpt Version]
-> ReaderT SqlBackend (RIO env) (Map (Key Version) 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 [] []
  Map (Key HackageCabal) HackageCabal
-> (HackageCabal
    -> ReaderT SqlBackend (RIO env) RawPackageLocationImmutable)
-> ReaderT
     SqlBackend
     (RIO env)
     (Map (Key HackageCabal) RawPackageLocationImmutable)
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 Key PackageName
-> Map (Key PackageName) PackageName -> Maybe PackageName
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 -> String -> ReaderT SqlBackend (RIO env) RawPackageLocationImmutable
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 Key Version -> Map (Key Version) Version -> Maybe Version
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 -> String -> ReaderT SqlBackend (RIO env) RawPackageLocationImmutable
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 -> [Filter Tree]
-> [SelectOpt Tree]
-> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m (Maybe (Entity record))
forall (m :: * -> *) record.
(MonadIO m, PersistRecordBackend record SqlBackend) =>
[Filter record]
-> [SelectOpt record]
-> ReaderT SqlBackend m (Maybe (Entity record))
selectFirst [EntityField Tree (Key Tree)
forall typ. (typ ~ Key Tree) => EntityField Tree typ
TreeId EntityField Tree (Key Tree) -> Key Tree -> Filter Tree
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key Tree
key] []
                              Maybe (Key Tree)
Nothing -> Maybe (Entity Tree)
-> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Entity Tree)
forall a. Maybe a
Nothing
                          Maybe BlobKey
mblobKey <-
                            ReaderT SqlBackend (RIO env) (Maybe BlobKey)
-> (Entity Tree -> ReaderT SqlBackend (RIO env) (Maybe BlobKey))
-> Maybe (Entity Tree)
-> ReaderT SqlBackend (RIO env) (Maybe BlobKey)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                              (Maybe BlobKey -> ReaderT SqlBackend (RIO env) (Maybe BlobKey)
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe BlobKey
forall a. Maybe a
Nothing)
                              (((BlobKey -> Maybe BlobKey)
-> ReaderT SqlBackend (RIO env) BlobKey
-> ReaderT SqlBackend (RIO env) (Maybe BlobKey)
forall a b.
(a -> b)
-> ReaderT SqlBackend (RIO env) a -> ReaderT SqlBackend (RIO env) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BlobKey -> Maybe BlobKey
forall a. a -> Maybe a
Just (ReaderT SqlBackend (RIO env) BlobKey
 -> ReaderT SqlBackend (RIO env) (Maybe BlobKey))
-> (Key Blob -> ReaderT SqlBackend (RIO env) BlobKey)
-> Key Blob
-> ReaderT SqlBackend (RIO env) (Maybe BlobKey)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key Blob -> ReaderT SqlBackend (RIO env) BlobKey
forall env. Key Blob -> ReaderT SqlBackend (RIO env) BlobKey
getBlobKey) (Key Blob -> ReaderT SqlBackend (RIO env) (Maybe BlobKey))
-> (Entity Tree -> Key Blob)
-> Entity Tree
-> ReaderT SqlBackend (RIO env) (Maybe BlobKey)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree -> Key Blob
treeKey (Tree -> Key Blob)
-> (Entity Tree -> Tree) -> Entity Tree -> Key Blob
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity Tree -> Tree
forall record. Entity record -> record
entityVal)
                              Maybe (Entity Tree)
mtree
                          RawPackageLocationImmutable
-> ReaderT SqlBackend (RIO env) RawPackageLocationImmutable
forall a. a -> ReaderT SqlBackend (RIO env) a
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)))
                               ((BlobKey -> TreeKey) -> Maybe BlobKey -> Maybe TreeKey
forall a b. (a -> b) -> Maybe a -> Maybe b
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 =
    ([Entity a] -> Map (Key a) a)
-> ReaderT backend m [Entity a]
-> ReaderT backend m (Map (Key a) a)
forall a b. (a -> b) -> ReaderT backend m a -> ReaderT backend m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(Key a, a)] -> Map (Key a) a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Key a, a)] -> Map (Key a) a)
-> ([Entity a] -> [(Key a, a)]) -> [Entity a] -> Map (Key a) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Entity a -> (Key a, a)) -> [Entity a] -> [(Key a, a)]
forall a b. (a -> b) -> [a] -> [b]
map Entity a -> (Key a, a)
forall {b}. Entity b -> (Key b, b)
tuple) ([Filter a] -> [SelectOpt a] -> ReaderT backend m [Entity a]
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 = [Filter Blob] -> ReaderT SqlBackend (RIO env) Int
forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m Int
forall (m :: * -> *) record.
(MonadIO m, PersistRecordBackend record SqlBackend) =>
[Filter record] -> ReaderT SqlBackend m Int
count [EntityField Blob (Key Blob)
forall typ. (typ ~ Key Blob) => EntityField Blob typ
BlobId EntityField Blob (Key Blob) -> Key Blob -> Filter Blob
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 =
  [Filter HackageCabal] -> ReaderT SqlBackend (RIO env) Int
forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m Int
forall (m :: * -> *) record.
(MonadIO m, PersistRecordBackend record SqlBackend) =>
[Filter record] -> ReaderT SqlBackend m Int
count
    [ EntityField HackageCabal (Key HackageCabal)
forall typ.
(typ ~ Key HackageCabal) =>
EntityField HackageCabal typ
HackageCabalId EntityField HackageCabal (Key HackageCabal)
-> Key HackageCabal -> Filter HackageCabal
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 <- Text
-> [PersistValue]
-> ReaderT SqlBackend (RIO env) [(Single SHA256, Single FileSize)]
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=?" [Key Blob -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue Key Blob
bid]
  case [(Single SHA256, Single FileSize)]
res of
    [] -> String -> ReaderT SqlBackend (RIO env) BlobKey
forall a. HasCallStack => String -> a
error (String -> ReaderT SqlBackend (RIO env) BlobKey)
-> String -> ReaderT SqlBackend (RIO env) BlobKey
forall a b. (a -> b) -> a -> b
$ String
"getBlobKey failed due to missing ID: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Key Blob -> String
forall a. Show a => a -> String
show Key Blob
bid
    [(Single SHA256
sha, Single FileSize
size)] -> BlobKey -> ReaderT SqlBackend (RIO env) BlobKey
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BlobKey -> ReaderT SqlBackend (RIO env) BlobKey)
-> BlobKey -> ReaderT SqlBackend (RIO env) BlobKey
forall a b. (a -> b) -> a -> b
$ SHA256 -> FileSize -> BlobKey
P.BlobKey SHA256
sha FileSize
size
    [(Single SHA256, Single FileSize)]
_ -> String -> ReaderT SqlBackend (RIO env) BlobKey
forall a. HasCallStack => String -> a
error (String -> ReaderT SqlBackend (RIO env) BlobKey)
-> String -> ReaderT SqlBackend (RIO env) BlobKey
forall a b. (a -> b) -> a -> b
$ String
"getBlobKey failed due to non-unique ID: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Key Blob, [(Single SHA256, Single FileSize)]) -> String
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 <- Text
-> [PersistValue]
-> ReaderT SqlBackend (RIO env) [Single (Key Blob)]
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=?"
           [SHA256 -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue SHA256
sha, FileSize -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue FileSize
size]
  Maybe (Key Blob) -> ReaderT SqlBackend (RIO env) (Maybe (Key Blob))
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Key Blob)
 -> ReaderT SqlBackend (RIO env) (Maybe (Key Blob)))
-> Maybe (Key Blob)
-> ReaderT SqlBackend (RIO env) (Maybe (Key Blob))
forall a b. (a -> b) -> a -> b
$ [Key Blob] -> Maybe (Key Blob)
forall a. [a] -> Maybe a
listToMaybe ([Key Blob] -> Maybe (Key Blob)) -> [Key Blob] -> Maybe (Key Blob)
forall a b. (a -> b) -> a -> b
$ (Single (Key Blob) -> Key Blob)
-> [Single (Key Blob)] -> [Key Blob]
forall a b. (a -> b) -> [a] -> [b]
map Single (Key Blob) -> Key Blob
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 <- Text
-> [PersistValue]
-> ReaderT SqlBackend (RIO env) [Single ByteString]
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"
    [Text -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue Text
url]
  case [Single ByteString]
ment of
    [] -> Maybe ByteString -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
forall a. Maybe a
Nothing
    (Single ByteString
bs) : [Single ByteString]
_ -> Maybe ByteString -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString
 -> ReaderT SqlBackend (RIO env) (Maybe ByteString))
-> Maybe ByteString
-> ReaderT SqlBackend (RIO env) (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
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
_) <- ByteString -> ReaderT SqlBackend (RIO env) (Key Blob, BlobKey)
forall env.
ByteString -> ReaderT SqlBackend (RIO env) (Key Blob, BlobKey)
storeBlob ByteString
blob
  UTCTime
now <- ReaderT SqlBackend (RIO env) UTCTime
forall (m :: * -> *). MonadIO m => m UTCTime
getCurrentTime
  UrlBlob -> ReaderT SqlBackend (RIO env) ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m ()
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend,
 SafeToInsert record) =>
record -> ReaderT SqlBackend 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 = [Filter HackageCabal] -> ReaderT SqlBackend (RIO env) ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
forall (m :: * -> *) record.
(MonadIO m, PersistRecordBackend record SqlBackend) =>
[Filter record] -> ReaderT SqlBackend 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 <- PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
forall env.
PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
getPackageNameId PackageName
name
  Key Version
versionid <- Version -> ReaderT SqlBackend (RIO env) (Key Version)
forall env. Version -> ReaderT SqlBackend (RIO env) (Key Version)
getVersionId Version
version
  Int
rev <- [Filter HackageCabal] -> ReaderT SqlBackend (RIO env) Int
forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m Int
forall (m :: * -> *) record.
(MonadIO m, PersistRecordBackend record SqlBackend) =>
[Filter record] -> ReaderT SqlBackend m Int
count
    [ EntityField HackageCabal (Key PackageName)
forall typ. (typ ~ Key PackageName) => EntityField HackageCabal typ
HackageCabalName EntityField HackageCabal (Key PackageName)
-> Key PackageName -> Filter HackageCabal
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key PackageName
nameid
    , EntityField HackageCabal (Key Version)
forall typ. (typ ~ Key Version) => EntityField HackageCabal typ
HackageCabalVersion EntityField HackageCabal (Key Version)
-> Key Version -> Filter HackageCabal
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key Version
versionid
    ]
  HackageCabal -> ReaderT SqlBackend (RIO env) ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m ()
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend,
 SafeToInsert record) =>
record -> ReaderT SqlBackend m ()
insert_ HackageCabal
    { hackageCabalName :: Key PackageName
hackageCabalName = Key PackageName
nameid
    , hackageCabalVersion :: Key Version
hackageCabalVersion = Key Version
versionid
    , hackageCabalRevision :: Revision
hackageCabalRevision = Word -> Revision
Revision (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
rev)
    , hackageCabalCabal :: Key Blob
hackageCabalCabal = Key Blob
key
    , hackageCabalTree :: Maybe (Key Tree)
hackageCabalTree = Maybe (Key Tree)
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 <- PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
forall env.
PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
getPackageNameId PackageName
name
  -- would be better with esqueleto

  (Map Revision BlobKey
 -> Map Revision BlobKey -> Map Revision BlobKey)
-> [(Version, Map Revision BlobKey)]
-> Map Version (Map Revision BlobKey)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Map Revision BlobKey
-> Map Revision BlobKey -> Map Revision BlobKey
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union ([(Version, Map Revision BlobKey)]
 -> Map Version (Map Revision BlobKey))
-> ([(Single Revision, Single VersionP, Single SHA256,
      Single FileSize)]
    -> [(Version, Map Revision BlobKey)])
-> [(Single Revision, Single VersionP, Single SHA256,
     Single FileSize)]
-> Map Version (Map Revision BlobKey)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Single Revision, Single VersionP, Single SHA256, Single FileSize)
 -> (Version, Map Revision BlobKey))
-> [(Single Revision, Single VersionP, Single SHA256,
     Single FileSize)]
-> [(Version, Map Revision BlobKey)]
forall a b. (a -> b) -> [a] -> [b]
map (Single Revision, Single VersionP, Single SHA256, Single FileSize)
-> (Version, Map Revision BlobKey)
forall {k}.
(Single k, Single VersionP, Single SHA256, Single FileSize)
-> (Version, Map k BlobKey)
go ([(Single Revision, Single VersionP, Single SHA256,
   Single FileSize)]
 -> Map Version (Map Revision BlobKey))
-> ReaderT
     SqlBackend
     (RIO env)
     [(Single Revision, Single VersionP, Single SHA256,
       Single FileSize)]
-> ReaderT
     SqlBackend (RIO env) (Map Version (Map Revision BlobKey))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> [PersistValue]
-> ReaderT
     SqlBackend
     (RIO env)
     [(Single Revision, Single VersionP, Single SHA256,
       Single FileSize)]
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"
    [Key PackageName -> PersistValue
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, k -> BlobKey -> Map k BlobKey
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 <- PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
forall env.
PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
getPackageNameId PackageName
name
  Key Version
versionid <- Version -> ReaderT SqlBackend (RIO env) (Key Version)
forall env. Version -> ReaderT SqlBackend (RIO env) (Key Version)
getVersionId Version
version
  -- would be better with esqueleto

  [(Revision, (Key Blob, BlobKey))]
-> Map Revision (Key Blob, BlobKey)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Revision, (Key Blob, BlobKey))]
 -> Map Revision (Key Blob, BlobKey))
-> ([(Single Revision, Single SHA256, Single FileSize,
      Single (Key Blob))]
    -> [(Revision, (Key Blob, BlobKey))])
-> [(Single Revision, Single SHA256, Single FileSize,
     Single (Key Blob))]
-> Map Revision (Key Blob, BlobKey)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Single Revision, Single SHA256, Single FileSize,
  Single (Key Blob))
 -> (Revision, (Key Blob, BlobKey)))
-> [(Single Revision, Single SHA256, Single FileSize,
     Single (Key Blob))]
-> [(Revision, (Key Blob, BlobKey))]
forall a b. (a -> b) -> [a] -> [b]
map (Single Revision, Single SHA256, Single FileSize,
 Single (Key Blob))
-> (Revision, (Key Blob, BlobKey))
forall {a} {a}.
(Single a, Single SHA256, Single FileSize, Single a)
-> (a, (a, BlobKey))
go ([(Single Revision, Single SHA256, Single FileSize,
   Single (Key Blob))]
 -> Map Revision (Key Blob, BlobKey))
-> ReaderT
     SqlBackend
     (RIO env)
     [(Single Revision, Single SHA256, Single FileSize,
       Single (Key Blob))]
-> ReaderT SqlBackend (RIO env) (Map Revision (Key Blob, BlobKey))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> [PersistValue]
-> ReaderT
     SqlBackend
     (RIO env)
     [(Single Revision, Single SHA256, Single FileSize,
       Single (Key Blob))]
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"
    [Key PackageName -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue Key PackageName
nameid, Key Version -> PersistValue
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 = (Entity CacheUpdate -> (FileSize, SHA256))
-> Maybe (Entity CacheUpdate) -> Maybe (FileSize, SHA256)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Entity CacheUpdate -> (FileSize, SHA256)
go (Maybe (Entity CacheUpdate) -> Maybe (FileSize, SHA256))
-> ReaderT SqlBackend (RIO env) (Maybe (Entity CacheUpdate))
-> ReaderT SqlBackend (RIO env) (Maybe (FileSize, SHA256))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Filter CacheUpdate]
-> [SelectOpt CacheUpdate]
-> ReaderT SqlBackend (RIO env) (Maybe (Entity CacheUpdate))
forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m (Maybe (Entity record))
forall (m :: * -> *) record.
(MonadIO m, PersistRecordBackend record SqlBackend) =>
[Filter record]
-> [SelectOpt record]
-> ReaderT SqlBackend m (Maybe (Entity record))
selectFirst [] [EntityField CacheUpdate UTCTime -> SelectOpt CacheUpdate
forall record typ. EntityField record typ -> SelectOpt record
Desc EntityField CacheUpdate UTCTime
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 <- ReaderT SqlBackend (RIO env) UTCTime
forall (m :: * -> *). MonadIO m => m UTCTime
getCurrentTime
  CacheUpdate -> ReaderT SqlBackend (RIO env) ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m ()
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend,
 SafeToInsert record) =>
record -> ReaderT SqlBackend 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 <- PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
forall env.
PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
getPackageNameId PackageName
name
  Key Version
versionid <- Version -> ReaderT SqlBackend (RIO env) (Key Version)
forall env. Version -> ReaderT SqlBackend (RIO env) (Key Version)
getVersionId Version
version
  ReaderT
  SqlBackend
  (RIO env)
  (Either (Entity HackageTarball) (Key HackageTarball))
-> ReaderT SqlBackend (RIO env) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT
   SqlBackend
   (RIO env)
   (Either (Entity HackageTarball) (Key HackageTarball))
 -> ReaderT SqlBackend (RIO env) ())
-> ReaderT
     SqlBackend
     (RIO env)
     (Either (Entity HackageTarball) (Key HackageTarball))
-> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ HackageTarball
-> ReaderT
     SqlBackend
     (RIO env)
     (Either (Entity HackageTarball) (Key HackageTarball))
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 <- PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
forall env.
PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
getPackageNameId PackageName
name
  Key Version
versionid <- Version -> ReaderT SqlBackend (RIO env) (Key Version)
forall env. Version -> ReaderT SqlBackend (RIO env) (Key Version)
getVersionId Version
version
  (Entity HackageTarball -> (SHA256, FileSize))
-> Maybe (Entity HackageTarball) -> Maybe (SHA256, FileSize)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Entity HackageTarball -> (SHA256, FileSize)
go (Maybe (Entity HackageTarball) -> Maybe (SHA256, FileSize))
-> ReaderT SqlBackend (RIO env) (Maybe (Entity HackageTarball))
-> ReaderT SqlBackend (RIO env) (Maybe (SHA256, FileSize))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Unique HackageTarball
-> ReaderT SqlBackend (RIO env) (Maybe (Entity HackageTarball))
forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Unique record -> ReaderT SqlBackend 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
_) <- ByteString -> ReaderT SqlBackend (RIO env) (Key Blob, 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)
_ <- FilePath
-> ReaderT
     SqlBackend (RIO env) (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}
  Key Blob -> ReaderT SqlBackend (RIO env) (Key Blob)
forall a. a -> ReaderT SqlBackend (RIO env) a
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 <- Unique FilePath
-> ReaderT SqlBackend (RIO env) (Maybe (Entity FilePath))
forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Unique record -> ReaderT SqlBackend m (Maybe (Entity record))
getBy (Unique FilePath
 -> ReaderT SqlBackend (RIO env) (Maybe (Entity FilePath)))
-> Unique FilePath
-> ReaderT SqlBackend (RIO env) (Maybe (Entity FilePath))
forall a b. (a -> b) -> a -> b
$ SafeFilePath -> Unique FilePath
UniqueSfp SafeFilePath
path
  case Maybe (Entity FilePath)
fp of
    Maybe (Entity FilePath)
Nothing -> String -> ReaderT SqlBackend (RIO env) (Entity FilePath)
forall a. HasCallStack => String -> a
error (String -> ReaderT SqlBackend (RIO env) (Entity FilePath))
-> String -> ReaderT SqlBackend (RIO env) (Entity FilePath)
forall a b. (a -> b) -> a -> b
$
      String
"loadFilePath: No row found for " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (SafeFilePath -> Text
P.unSafeFilePath SafeFilePath
path)
    Just Entity FilePath
record -> Entity FilePath -> ReaderT SqlBackend (RIO env) (Entity FilePath)
forall a. a -> ReaderT SqlBackend (RIO env) a
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 <- SafeFilePath -> ReaderT SqlBackend (RIO env) (Entity FilePath)
forall env.
SafeFilePath -> ReaderT SqlBackend (RIO env) (Entity FilePath)
loadFilePath SafeFilePath
P.hpackSafeFilePath
  let Key FilePath
filePathId :: FilePathId = Entity FilePath -> Key FilePath
forall record. Entity record -> Key record
entityKey Entity FilePath
filepath
  Maybe (Entity TreeEntry)
hpackTreeEntry <-
    [Filter TreeEntry]
-> [SelectOpt TreeEntry]
-> ReaderT SqlBackend (RIO env) (Maybe (Entity TreeEntry))
forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m (Maybe (Entity record))
forall (m :: * -> *) record.
(MonadIO m, PersistRecordBackend record SqlBackend) =>
[Filter record]
-> [SelectOpt record]
-> ReaderT SqlBackend m (Maybe (Entity record))
selectFirst [EntityField TreeEntry (Key Tree)
forall typ. (typ ~ Key Tree) => EntityField TreeEntry typ
TreeEntryTree EntityField TreeEntry (Key Tree) -> Key Tree -> Filter TreeEntry
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key Tree
tid, EntityField TreeEntry (Key FilePath)
forall typ. (typ ~ Key FilePath) => EntityField TreeEntry typ
TreeEntryPath EntityField TreeEntry (Key FilePath)
-> Key FilePath -> Filter TreeEntry
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key FilePath
filePathId] []
  case Maybe (Entity TreeEntry)
hpackTreeEntry of
    Maybe (Entity TreeEntry)
Nothing -> String -> ReaderT SqlBackend (RIO env) (Entity TreeEntry)
forall a. HasCallStack => String -> a
error (String -> ReaderT SqlBackend (RIO env) (Entity TreeEntry))
-> String -> ReaderT SqlBackend (RIO env) (Entity TreeEntry)
forall a b. (a -> b) -> a -> b
$
         String
"loadHPackTreeEntity: No package.yaml file found in TreeEntry for TreeId:  "
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ Key Tree -> String
forall a. Show a => a -> String
show Key Tree
tid
    Just Entity TreeEntry
record -> Entity TreeEntry -> ReaderT SqlBackend (RIO env) (Entity TreeEntry)
forall a. a -> ReaderT SqlBackend (RIO env) a
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 <- ReaderT SqlBackend (RIO env) (Key Version)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
ReaderT SqlBackend (RIO env) (Key Version)
hpackVersionId
  Maybe (Entity HPack)
hpackRecord <- Unique HPack -> ReaderT SqlBackend (RIO env) (Maybe (Entity HPack))
forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Unique record -> ReaderT SqlBackend 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 -> RawPackageLocationImmutable
-> Key Tree
-> Key Version
-> ReaderT SqlBackend (RIO env) (Key HPack)
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 -> Key HPack -> ReaderT SqlBackend (RIO env) (Key HPack)
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Key HPack -> ReaderT SqlBackend (RIO env) (Key HPack))
-> Key HPack -> ReaderT SqlBackend (RIO env) (Key HPack)
forall a b. (a -> b) -> a -> b
$ Entity HPack -> Key HPack
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 <- Key HPack -> ReaderT SqlBackend (RIO env) HPack
forall record backend (m :: * -> *).
(PersistStoreRead backend, PersistRecordBackend record backend,
 MonadIO m) =>
Key record -> ReaderT backend m record
getJust Key HPack
hpackId
  Key Blob -> ReaderT SqlBackend (RIO env) BlobKey
forall env. Key Blob -> ReaderT SqlBackend (RIO env) BlobKey
getBlobKey (Key Blob -> ReaderT SqlBackend (RIO env) BlobKey)
-> Key Blob -> ReaderT SqlBackend (RIO env) BlobKey
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 <- Key Tree -> ReaderT SqlBackend (RIO env) Tree
forall env. Key Tree -> ReaderT SqlBackend (RIO env) Tree
getTree Key Tree
tid
  (PackageName
pkgName, ByteString
cabalBS) <- RawPackageLocationImmutable
-> Tree -> ReaderT SqlBackend (RIO env) (PackageName, ByteString)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> Tree -> ReaderT SqlBackend (RIO env) (PackageName, ByteString)
hpackToCabalS RawPackageLocationImmutable
rpli Tree
tree
  Key Blob
bid <- ByteString
-> PackageName -> ReaderT SqlBackend (RIO env) (Key Blob)
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 <- FilePath
-> ReaderT
     SqlBackend (RIO env) (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}
  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 = (Entity FilePath -> Key FilePath)
-> (Key FilePath -> Key FilePath)
-> Either (Entity FilePath) (Key FilePath)
-> Key FilePath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Entity FilePath -> Key FilePath
forall record. Entity record -> Key record
entityKey Key FilePath -> Key FilePath
forall a. a -> a
id Either (Entity FilePath) (Key FilePath)
fid
          }
  (Entity HPack -> Key HPack)
-> (Key HPack -> Key HPack)
-> Either (Entity HPack) (Key HPack)
-> Key HPack
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Entity HPack -> Key HPack
forall record. Entity record -> Key record
entityKey Key HPack -> Key HPack
forall a. a -> a
id (Either (Entity HPack) (Key HPack) -> Key HPack)
-> ReaderT SqlBackend (RIO env) (Either (Entity HPack) (Key HPack))
-> ReaderT SqlBackend (RIO env) (Key HPack)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HPack
-> ReaderT SqlBackend (RIO env) (Either (Entity HPack) (Key HPack))
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 <- RIO env Version -> ReaderT SqlBackend (RIO env) Version
forall (m :: * -> *) a. Monad m => m a -> ReaderT SqlBackend m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift RIO env Version
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RIO env Version
hpackVersion
  (Either (Entity Version) (Key Version) -> Key Version)
-> ReaderT
     SqlBackend (RIO env) (Either (Entity Version) (Key Version))
-> ReaderT SqlBackend (RIO env) (Key Version)
forall a b.
(a -> b)
-> ReaderT SqlBackend (RIO env) a -> ReaderT SqlBackend (RIO env) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Entity Version -> Key Version)
-> (Key Version -> Key Version)
-> Either (Entity Version) (Key Version)
-> Key Version
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Entity Version -> Key Version
forall record. Entity record -> Key record
entityKey Key Version -> Key Version
forall a. a -> a
id) (ReaderT
   SqlBackend (RIO env) (Either (Entity Version) (Key Version))
 -> ReaderT SqlBackend (RIO env) (Key Version))
-> ReaderT
     SqlBackend (RIO env) (Either (Entity Version) (Key Version))
-> ReaderT SqlBackend (RIO env) (Key Version)
forall a b. (a -> b) -> a -> b
$
    Version
-> ReaderT
     SqlBackend (RIO env) (Either (Entity Version) (Key Version))
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 (Version
 -> ReaderT
      SqlBackend (RIO env) (Either (Entity Version) (Key Version)))
-> Version
-> ReaderT
     SqlBackend (RIO env) (Either (Entity Version) (Key Version))
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 =
  [Filter FilePath]
-> [SelectOpt FilePath]
-> ReaderT SqlBackend (RIO env) [Key FilePath]
forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Key record]
selectKeysList [EntityField FilePath SafeFilePath
forall typ. (typ ~ SafeFilePath) => EntityField FilePath typ
FilePathPath EntityField FilePath SafeFilePath
-> SafeFilePath -> Filter FilePath
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. SafeFilePath
sfp] [] ReaderT SqlBackend (RIO env) [Key FilePath]
-> ([Key FilePath] -> ReaderT SqlBackend (RIO env) (Key FilePath))
-> ReaderT SqlBackend (RIO env) (Key FilePath)
forall a b.
ReaderT SqlBackend (RIO env) a
-> (a -> ReaderT SqlBackend (RIO env) b)
-> ReaderT SqlBackend (RIO env) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    [Key FilePath
fpId] -> Key FilePath -> ReaderT SqlBackend (RIO env) (Key FilePath)
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Key FilePath
fpId
    [] ->
      RdbmsActions env (Key FilePath)
-> ReaderT SqlBackend (RIO env) (Key FilePath)
forall env a. RdbmsActions env a -> ReaderT SqlBackend (RIO env) a
rdbmsAwareQuery
        RdbmsActions
          { raSqlite :: ReaderT SqlBackend (RIO env) (Key FilePath)
raSqlite = FilePath -> ReaderT SqlBackend (RIO env) (Key FilePath)
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m (Key record)
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend,
 SafeToInsert record) =>
record -> ReaderT SqlBackend m (Key record)
insert (FilePath -> ReaderT SqlBackend (RIO env) (Key FilePath))
-> FilePath -> ReaderT SqlBackend (RIO env) (Key FilePath)
forall a b. (a -> b) -> a -> b
$ SafeFilePath -> FilePath
FilePath SafeFilePath
sfp
          , raPostgres :: ReaderT SqlBackend (RIO env) (Key FilePath)
raPostgres = do
              Text -> [PersistValue] -> ReaderT SqlBackend (RIO env) ()
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"
                [SafeFilePath -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue SafeFilePath
sfp]
              Text
-> [PersistValue]
-> ReaderT SqlBackend (RIO env) [Single (Key FilePath)]
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 = ?"
                [SafeFilePath -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue SafeFilePath
sfp] ReaderT SqlBackend (RIO env) [Single (Key FilePath)]
-> ([Single (Key FilePath)]
    -> ReaderT SqlBackend (RIO env) (Key FilePath))
-> ReaderT SqlBackend (RIO env) (Key FilePath)
forall a b.
ReaderT SqlBackend (RIO env) a
-> (a -> ReaderT SqlBackend (RIO env) b)
-> ReaderT SqlBackend (RIO env) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                [Single Key FilePath
key] -> Key FilePath -> ReaderT SqlBackend (RIO env) (Key FilePath)
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Key FilePath
key
                [Single (Key FilePath)]
_ -> String -> ReaderT SqlBackend (RIO env) (Key FilePath)
forall a. HasCallStack => String -> a
error
                  String
"getFilePathId: there was a critical problem storing a blob."
          }
    [Key FilePath]
_ ->
      String -> ReaderT SqlBackend (RIO env) (Key FilePath)
forall a. HasCallStack => String -> a
error (String -> ReaderT SqlBackend (RIO env) (Key FilePath))
-> String -> ReaderT SqlBackend (RIO env) (Key FilePath)
forall a b. (a -> b) -> a -> b
$
      String
"getFilePathId: FilePath unique constraint key is violated for: " String -> ShowS
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
(Int -> CachedTree -> ShowS)
-> (CachedTree -> String)
-> ([CachedTree] -> ShowS)
-> Show CachedTree
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CachedTree -> ShowS
showsPrec :: Int -> CachedTree -> ShowS
$cshow :: CachedTree -> String
show :: CachedTree -> String
$cshowList :: [CachedTree] -> ShowS
showList :: [CachedTree] -> ShowS
Show

unCachedTree :: CachedTree -> P.Tree
unCachedTree :: CachedTree -> Tree
unCachedTree (CachedTreeMap Map SafeFilePath (TreeEntry, Key Blob)
m) = Map SafeFilePath TreeEntry -> Tree
P.TreeMap (Map SafeFilePath TreeEntry -> Tree)
-> Map SafeFilePath TreeEntry -> Tree
forall a b. (a -> b) -> a -> b
$ (TreeEntry, Key Blob) -> TreeEntry
forall a b. (a, b) -> a
fst ((TreeEntry, Key Blob) -> TreeEntry)
-> Map SafeFilePath (TreeEntry, Key Blob)
-> Map SafeFilePath TreeEntry
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) <- ByteString -> ReaderT SqlBackend (RIO env) (Key Blob, BlobKey)
forall env.
ByteString -> ReaderT SqlBackend (RIO env) (Key Blob, BlobKey)
storeBlob (ByteString -> ReaderT SqlBackend (RIO env) (Key Blob, BlobKey))
-> ByteString -> ReaderT SqlBackend (RIO env) (Key Blob, BlobKey)
forall a b. (a -> b) -> a -> b
$ Tree -> ByteString
P.renderTree (Tree -> ByteString) -> Tree -> ByteString
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) -> (Maybe (Key Blob), FileType)
-> ReaderT SqlBackend (RIO env) (Maybe (Key Blob), FileType)
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Key Blob)
forall a. Maybe a
Nothing, FileType
ftype)
    P.BFCabal SafeFilePath
_ (P.TreeEntry (P.BlobKey SHA256
btypeSha FileSize
_) FileType
ftype) -> do
      Maybe (Key Blob)
buildTypeid <- SHA256 -> ReaderT SqlBackend (RIO env) (Maybe (Key Blob))
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 -> Key Blob -> ReaderT SqlBackend (RIO env) (Key Blob)
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Key Blob
buildId
          Maybe (Key Blob)
Nothing -> String -> ReaderT SqlBackend (RIO env) (Key Blob)
forall a. HasCallStack => String -> a
error (String -> ReaderT SqlBackend (RIO env) (Key Blob))
-> String -> ReaderT SqlBackend (RIO env) (Key Blob)
forall a b. (a -> b) -> a -> b
$
               String
"storeTree: "
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ BuildFile -> String
forall a. Show a => a -> String
show BuildFile
buildFile
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" BlobKey not found: "
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ (CachedTree, SHA256) -> String
forall a. Show a => a -> String
show (CachedTree
tree, SHA256
btypeSha)
      (Maybe (Key Blob), FileType)
-> ReaderT SqlBackend (RIO env) (Maybe (Key Blob), FileType)
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Key Blob -> Maybe (Key Blob)
forall a. a -> Maybe a
Just Key Blob
buildid, FileType
ftype)
  Key PackageName
nameid <- PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
forall env.
PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
getPackageNameId PackageName
name
  Key Version
versionid <- Version -> ReaderT SqlBackend (RIO env) (Key Version)
forall env. Version -> ReaderT SqlBackend (RIO env) (Key Version)
getVersionId Version
version
  Either (Entity Tree) (Key Tree)
etid <- Tree
-> ReaderT SqlBackend (RIO env) (Either (Entity Tree) (Key Tree))
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
_) -> (Key Tree, TreeKey)
-> ReaderT SqlBackend (RIO env) (Key Tree, TreeKey)
forall a. a -> ReaderT SqlBackend (RIO env) a
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
      [(SafeFilePath, (TreeEntry, Key Blob))]
-> ((SafeFilePath, (TreeEntry, Key Blob))
    -> ReaderT SqlBackend (RIO env) ())
-> ReaderT SqlBackend (RIO env) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Map SafeFilePath (TreeEntry, Key Blob)
-> [(SafeFilePath, (TreeEntry, Key Blob))]
forall k a. Map k a -> [(k, a)]
Map.toList Map SafeFilePath (TreeEntry, Key Blob)
m) (((SafeFilePath, (TreeEntry, Key Blob))
  -> ReaderT SqlBackend (RIO env) ())
 -> ReaderT SqlBackend (RIO env) ())
-> ((SafeFilePath, (TreeEntry, Key Blob))
    -> ReaderT SqlBackend (RIO env) ())
-> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ \(SafeFilePath
sfp, (P.TreeEntry BlobKey
_blobKey FileType
ft, Key Blob
bid')) -> do
        Key FilePath
sfpid <- SafeFilePath -> ReaderT SqlBackend (RIO env) (Key FilePath)
forall env.
SafeFilePath -> ReaderT SqlBackend (RIO env) (Key FilePath)
getFilePathId SafeFilePath
sfp
        TreeEntry -> ReaderT SqlBackend (RIO env) ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m ()
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend,
 SafeToInsert record) =>
record -> ReaderT SqlBackend 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
          }
      (Key Tree, TreeKey)
-> ReaderT SqlBackend (RIO env) (Key Tree, TreeKey)
forall a. a -> ReaderT SqlBackend (RIO env) a
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
_ -> ReaderT SqlBackend (RIO env) (Key HPack)
-> ReaderT SqlBackend (RIO env) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT SqlBackend (RIO env) (Key HPack)
 -> ReaderT SqlBackend (RIO env) ())
-> ReaderT SqlBackend (RIO env) (Key HPack)
-> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable
-> Key Tree -> ReaderT SqlBackend (RIO env) (Key HPack)
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
_ -> () -> ReaderT SqlBackend (RIO env) ()
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  (Key Tree, TreeKey)
-> ReaderT SqlBackend (RIO env) (Key Tree, TreeKey)
forall a. a -> ReaderT SqlBackend (RIO env) a
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) <- Key Tree -> ReaderT SqlBackend (RIO env) (Maybe Tree)
forall backend record (m :: * -> *).
(PersistStoreRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Key record -> ReaderT SqlBackend m (Maybe record)
get Key Tree
tid
  Tree
ts <-
      case Maybe Tree
mts of
        Maybe Tree
Nothing ->
            String -> ReaderT SqlBackend (RIO env) Tree
forall a. HasCallStack => String -> a
error (String -> ReaderT SqlBackend (RIO env) Tree)
-> String -> ReaderT SqlBackend (RIO env) Tree
forall a b. (a -> b) -> a -> b
$ String
"getTree: invalid foreign key " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Key Tree -> String
forall a. Show a => a -> String
show Key Tree
tid
        Just Tree
ts -> Tree -> ReaderT SqlBackend (RIO env) Tree
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tree
ts
  Entity Tree -> ReaderT SqlBackend (RIO env) Tree
forall env. Entity Tree -> ReaderT SqlBackend (RIO env) Tree
loadTreeByEnt (Entity Tree -> ReaderT SqlBackend (RIO env) Tree)
-> Entity Tree -> ReaderT SqlBackend (RIO env) Tree
forall a b. (a -> b) -> a -> b
$ Key Tree -> Tree -> Entity Tree
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 <- TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
forall env.
TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
getTreeForKey TreeKey
key
  case Maybe (Entity Tree)
ment of
    Maybe (Entity Tree)
Nothing -> Maybe Tree -> ReaderT SqlBackend (RIO env) (Maybe Tree)
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Tree
forall a. Maybe a
Nothing
    Just Entity Tree
ent -> Tree -> Maybe Tree
forall a. a -> Maybe a
Just (Tree -> Maybe Tree)
-> ReaderT SqlBackend (RIO env) Tree
-> ReaderT SqlBackend (RIO env) (Maybe Tree)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Entity Tree -> ReaderT SqlBackend (RIO env) Tree
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 <- BlobKey -> ReaderT SqlBackend (RIO env) (Maybe (Key Blob))
forall env.
BlobKey -> ReaderT SqlBackend (RIO env) (Maybe (Key Blob))
getBlobId BlobKey
key
  case Maybe (Key Blob)
mbid of
    Maybe (Key Blob)
Nothing -> Maybe (Entity Tree)
-> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Entity Tree)
forall a. Maybe a
Nothing
    Just Key Blob
bid -> Unique Tree -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Unique record -> ReaderT SqlBackend m (Maybe (Entity record))
getBy (Unique Tree -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree)))
-> Unique Tree
-> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
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) <- Key Tree -> ReaderT SqlBackend (RIO env) (Maybe Tree)
forall backend record (m :: * -> *).
(PersistStoreRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Key record -> ReaderT SqlBackend m (Maybe record)
get Key Tree
tid
  Tree
ts <- case Maybe Tree
mts of
    Maybe Tree
Nothing ->
      String -> ReaderT SqlBackend (RIO env) Tree
forall a. HasCallStack => String -> a
error (String -> ReaderT SqlBackend (RIO env) Tree)
-> String -> ReaderT SqlBackend (RIO env) Tree
forall a b. (a -> b) -> a -> b
$ String
"loadPackageById: invalid foreign key " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Key Tree -> String
forall a. Show a => a -> String
show Key Tree
tid
    Just Tree
ts -> Tree -> ReaderT SqlBackend (RIO env) Tree
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tree
ts
  (Tree
tree :: P.Tree) <- Entity Tree -> ReaderT SqlBackend (RIO env) Tree
forall env. Entity Tree -> ReaderT SqlBackend (RIO env) Tree
loadTreeByEnt (Entity Tree -> ReaderT SqlBackend (RIO env) Tree)
-> Entity Tree -> ReaderT SqlBackend (RIO env) Tree
forall a b. (a -> b) -> a -> b
$ Key Tree -> Tree -> Entity Tree
forall record. Key record -> record -> Entity record
Entity Key Tree
tid Tree
ts
  (BlobKey
blobKey :: BlobKey) <- Key Blob -> ReaderT SqlBackend (RIO env) BlobKey
forall env. Key Blob -> ReaderT SqlBackend (RIO env) BlobKey
getBlobKey (Key Blob -> ReaderT SqlBackend (RIO env) BlobKey)
-> Key Blob -> ReaderT SqlBackend (RIO env) BlobKey
forall a b. (a -> b) -> a -> b
$ Tree -> Key Blob
treeKey Tree
ts
  (Maybe PackageName
mname :: Maybe PackageName) <- Key PackageName -> ReaderT SqlBackend (RIO env) (Maybe PackageName)
forall backend record (m :: * -> *).
(PersistStoreRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Key record -> ReaderT SqlBackend m (Maybe record)
get (Key PackageName
 -> ReaderT SqlBackend (RIO env) (Maybe PackageName))
-> Key PackageName
-> ReaderT SqlBackend (RIO env) (Maybe PackageName)
forall a b. (a -> b) -> a -> b
$ Tree -> Key PackageName
treeName Tree
ts
  PackageName
name <- case Maybe PackageName
mname of
    Maybe PackageName
Nothing -> String -> ReaderT SqlBackend (RIO env) PackageName
forall a. HasCallStack => String -> a
error (String -> ReaderT SqlBackend (RIO env) PackageName)
-> String -> ReaderT SqlBackend (RIO env) PackageName
forall a b. (a -> b) -> a -> b
$
      String
"loadPackageByid: invalid foreign key " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Key PackageName -> String
forall a. Show a => a -> String
show (Tree -> Key PackageName
treeName Tree
ts)
    Just (PackageName (P.PackageNameP PackageName
name)) -> PackageName -> ReaderT SqlBackend (RIO env) PackageName
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageName
name
  Maybe Version
mversion <- Key Version -> ReaderT SqlBackend (RIO env) (Maybe Version)
forall backend record (m :: * -> *).
(PersistStoreRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Key record -> ReaderT SqlBackend m (Maybe record)
get (Key Version -> ReaderT SqlBackend (RIO env) (Maybe Version))
-> Key Version -> ReaderT SqlBackend (RIO env) (Maybe Version)
forall a b. (a -> b) -> a -> b
$ Tree -> Key Version
treeVersion Tree
ts
  Version
version <- case Maybe Version
mversion of
    Maybe Version
Nothing -> String -> ReaderT SqlBackend (RIO env) Version
forall a. HasCallStack => String -> a
error (String -> ReaderT SqlBackend (RIO env) Version)
-> String -> ReaderT SqlBackend (RIO env) Version
forall a b. (a -> b) -> a -> b
$
      String
"loadPackageByid: invalid foreign key " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Key Version -> String
forall a. Show a => a -> String
show (Tree -> Key Version
treeVersion Tree
ts)
    Just (Version (P.VersionP Version
version)) -> Version -> ReaderT SqlBackend (RIO env) Version
forall a. a -> ReaderT SqlBackend (RIO env) a
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 <- Key Blob -> ReaderT SqlBackend (RIO env) BlobKey
forall env. Key Blob -> ReaderT SqlBackend (RIO env) BlobKey
getBlobKey Key Blob
keyBlob
      (PackageCabal, Tree)
-> ReaderT SqlBackend (RIO env) (PackageCabal, Tree)
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( TreeEntry -> PackageCabal
P.PCCabalFile (TreeEntry -> PackageCabal) -> TreeEntry -> PackageCabal
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 <- ReaderT SqlBackend (RIO env) (Key Version)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
ReaderT SqlBackend (RIO env) (Key Version)
hpackVersionId
      Maybe (Entity HPack)
hpackEntity <- Unique HPack -> ReaderT SqlBackend (RIO env) (Maybe (Entity HPack))
forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Unique record -> ReaderT SqlBackend 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) <- RawPackageLocationImmutable
-> Key Tree -> ReaderT SqlBackend (RIO env) (Key HPack)
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 <- Key HPack -> ReaderT SqlBackend (RIO env) HPack
forall record backend (m :: * -> *).
(PersistStoreRead backend, PersistRecordBackend record backend,
 MonadIO m) =>
Key record -> ReaderT backend m record
getJust Key HPack
hpackId
          HPack
-> Tree
-> Map SafeFilePath TreeEntry
-> SafeFilePath
-> ReaderT SqlBackend (RIO env) (PackageCabal, Tree)
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) ->
          HPack
-> Tree
-> Map SafeFilePath TreeEntry
-> SafeFilePath
-> ReaderT SqlBackend (RIO env) (PackageCabal, Tree)
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
  Package -> ReaderT SqlBackend (RIO env) Package
forall a. a -> ReaderT SqlBackend (RIO env) a
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 <- Key Tree -> ReaderT SqlBackend (RIO env) (Entity TreeEntry)
forall env.
Key Tree -> ReaderT SqlBackend (RIO env) (Entity TreeEntry)
loadHPackTreeEntity Key Tree
treeId
  Key Blob -> ReaderT SqlBackend (RIO env) BlobKey
forall env. Key Blob -> ReaderT SqlBackend (RIO env) BlobKey
getBlobKey (TreeEntry -> Key Blob
treeEntryBlob (TreeEntry -> Key Blob) -> TreeEntry -> Key Blob
forall a b. (a -> b) -> a -> b
$ Entity TreeEntry -> TreeEntry
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 <- Key HPack -> ReaderT SqlBackend (RIO env) HPack
forall record backend (m :: * -> *).
(PersistStoreRead backend, PersistRecordBackend record backend,
 MonadIO m) =>
Key record -> ReaderT backend m record
getJust Key HPack
hpackId
  HPack -> ReaderT SqlBackend (RIO env) BlobKey
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 <- Key Blob -> ReaderT SqlBackend (RIO env) BlobKey
forall env. Key Blob -> ReaderT SqlBackend (RIO env) BlobKey
getBlobKey (HPack -> Key Blob
hPackCabalBlob HPack
hpackRecord)
  BlobKey
hpackKey <- HPack -> ReaderT SqlBackend (RIO env) BlobKey
forall env. HPack -> ReaderT SqlBackend (RIO env) BlobKey
getHPackBlobKey HPack
hpackRecord
  Version
hpackSoftwareVersion <- RIO env Version -> ReaderT SqlBackend (RIO env) Version
forall (m :: * -> *) a. Monad m => m a -> ReaderT SqlBackend m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift RIO env Version
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 (Map SafeFilePath TreeEntry -> Tree)
-> Map SafeFilePath TreeEntry -> Tree
forall a b. (a -> b) -> a -> b
$ SafeFilePath
-> TreeEntry
-> Map SafeFilePath TreeEntry
-> Map SafeFilePath TreeEntry
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert SafeFilePath
cabalFile TreeEntry
cbTreeEntry Map SafeFilePath TreeEntry
tmap
  (PackageCabal, Tree)
-> ReaderT SqlBackend (RIO env) (PackageCabal, Tree)
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( PHpack -> PackageCabal
P.PCHpack (PHpack -> PackageCabal) -> PHpack -> PackageCabal
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 <- Text
-> [PersistValue]
-> ReaderT
     SqlBackend
     (RIO env)
     [(Single SafeFilePath, Single SHA256, Single FileSize,
       Single FileType)]
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"
    [Key Tree -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue Key Tree
tid]
  Tree -> ReaderT SqlBackend (RIO env) Tree
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tree -> ReaderT SqlBackend (RIO env) Tree)
-> Tree -> ReaderT SqlBackend (RIO env) Tree
forall a b. (a -> b) -> a -> b
$ Map SafeFilePath TreeEntry -> Tree
P.TreeMap (Map SafeFilePath TreeEntry -> Tree)
-> Map SafeFilePath TreeEntry -> Tree
forall a b. (a -> b) -> a -> b
$ [(SafeFilePath, TreeEntry)] -> Map SafeFilePath TreeEntry
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(SafeFilePath, TreeEntry)] -> Map SafeFilePath TreeEntry)
-> [(SafeFilePath, TreeEntry)] -> Map SafeFilePath TreeEntry
forall a b. (a -> b) -> a -> b
$ ((Single SafeFilePath, Single SHA256, Single FileSize,
  Single FileType)
 -> (SafeFilePath, TreeEntry))
-> [(Single SafeFilePath, Single SHA256, Single FileSize,
     Single FileType)]
-> [(SafeFilePath, TreeEntry)]
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 <- PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
forall env.
PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
getPackageNameId PackageName
name
  Key Version
versionid <- Version -> ReaderT SqlBackend (RIO env) (Key Version)
forall env. Version -> ReaderT SqlBackend (RIO env) (Key Version)
getVersionId Version
version
  Maybe (Entity Tree)
ment <- TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
forall env.
TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
getTreeForKey TreeKey
treeKey'
  Maybe (Entity Tree)
-> (Entity Tree -> ReaderT SqlBackend (RIO env) ())
-> ReaderT SqlBackend (RIO env) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (Entity Tree)
ment ((Entity Tree -> ReaderT SqlBackend (RIO env) ())
 -> ReaderT SqlBackend (RIO env) ())
-> (Entity Tree -> ReaderT SqlBackend (RIO env) ())
-> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ \Entity Tree
ent -> [Filter HackageCabal]
-> [Update HackageCabal] -> ReaderT SqlBackend (RIO env) ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> [Update record] -> ReaderT backend m ()
forall (m :: * -> *) record.
(MonadIO m, PersistRecordBackend record SqlBackend) =>
[Filter record] -> [Update record] -> ReaderT SqlBackend m ()
updateWhere
    [ EntityField HackageCabal (Key PackageName)
forall typ. (typ ~ Key PackageName) => EntityField HackageCabal typ
HackageCabalName EntityField HackageCabal (Key PackageName)
-> Key PackageName -> Filter HackageCabal
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key PackageName
nameid
    , EntityField HackageCabal (Key Version)
forall typ. (typ ~ Key Version) => EntityField HackageCabal typ
HackageCabalVersion EntityField HackageCabal (Key Version)
-> Key Version -> Filter HackageCabal
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key Version
versionid
    , EntityField HackageCabal (Key Blob)
forall typ. (typ ~ Key Blob) => EntityField HackageCabal typ
HackageCabalCabal EntityField HackageCabal (Key Blob)
-> Key Blob -> Filter HackageCabal
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key Blob
cabal
    ]
    [EntityField HackageCabal (Maybe (Key Tree))
forall typ.
(typ ~ Maybe (Key Tree)) =>
EntityField HackageCabal typ
HackageCabalTree EntityField HackageCabal (Maybe (Key Tree))
-> Maybe (Key Tree) -> Update HackageCabal
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. Key Tree -> Maybe (Key Tree)
forall a. a -> Maybe a
Just (Entity Tree -> Key Tree
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 <- Text
-> [PersistValue]
-> ReaderT SqlBackend (RIO env) [(Single SHA256, Single FileSize)]
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"
    [ PackageNameP -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue (PackageNameP -> PersistValue) -> PackageNameP -> PersistValue
forall a b. (a -> b) -> a -> b
$ PackageName -> PackageNameP
P.PackageNameP PackageName
name
    , VersionP -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue (VersionP -> PersistValue) -> VersionP -> PersistValue
forall a b. (a -> b) -> a -> b
$ Version -> VersionP
P.VersionP Version
ver
    , SHA256 -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue SHA256
sha
    ]
  case [(Single SHA256, Single FileSize)]
res of
    [] -> Maybe TreeKey -> ReaderT SqlBackend (RIO env) (Maybe TreeKey)
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe TreeKey
forall a. Maybe a
Nothing
    (Single SHA256
treesha, Single FileSize
size):[(Single SHA256, Single FileSize)]
_ ->
      Maybe TreeKey -> ReaderT SqlBackend (RIO env) (Maybe TreeKey)
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe TreeKey -> ReaderT SqlBackend (RIO env) (Maybe TreeKey))
-> Maybe TreeKey -> ReaderT SqlBackend (RIO env) (Maybe TreeKey)
forall a b. (a -> b) -> a -> b
$ TreeKey -> Maybe TreeKey
forall a. a -> Maybe a
Just (TreeKey -> Maybe TreeKey) -> TreeKey -> Maybe TreeKey
forall a b. (a -> b) -> a -> b
$ BlobKey -> TreeKey
P.TreeKey (BlobKey -> TreeKey) -> BlobKey -> 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 <- PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
forall env.
PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
getPackageNameId PackageName
name
  Key Version
versionid <- Version -> ReaderT SqlBackend (RIO env) (Key Version)
forall env. Version -> ReaderT SqlBackend (RIO env) (Key Version)
getVersionId Version
ver
  Maybe (Entity HackageCabal)
ment <- [Filter HackageCabal]
-> [SelectOpt HackageCabal]
-> ReaderT SqlBackend (RIO env) (Maybe (Entity HackageCabal))
forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m (Maybe (Entity record))
forall (m :: * -> *) record.
(MonadIO m, PersistRecordBackend record SqlBackend) =>
[Filter record]
-> [SelectOpt record]
-> ReaderT SqlBackend m (Maybe (Entity record))
selectFirst
    [ EntityField HackageCabal (Key PackageName)
forall typ. (typ ~ Key PackageName) => EntityField HackageCabal typ
HackageCabalName EntityField HackageCabal (Key PackageName)
-> Key PackageName -> Filter HackageCabal
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key PackageName
nameid
    , EntityField HackageCabal (Key Version)
forall typ. (typ ~ Key Version) => EntityField HackageCabal typ
HackageCabalVersion EntityField HackageCabal (Key Version)
-> Key Version -> Filter HackageCabal
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key Version
versionid
    , EntityField HackageCabal (Key Blob)
forall typ. (typ ~ Key Blob) => EntityField HackageCabal typ
HackageCabalCabal EntityField HackageCabal (Key Blob)
-> Key Blob -> Filter HackageCabal
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key Blob
bid
    , EntityField HackageCabal (Maybe (Key Tree))
forall typ.
(typ ~ Maybe (Key Tree)) =>
EntityField HackageCabal typ
HackageCabalTree EntityField HackageCabal (Maybe (Key Tree))
-> Maybe (Key Tree) -> Filter HackageCabal
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
!=. Maybe (Key Tree)
forall a. Maybe a
Nothing
    ]
    []
  case Maybe (Entity HackageCabal)
ment of
    Maybe (Entity HackageCabal)
Nothing -> Maybe Package -> ReaderT SqlBackend (RIO env) (Maybe Package)
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Package
forall a. Maybe a
Nothing
    Just (Entity Key HackageCabal
_ HackageCabal
hc) ->
      case HackageCabal -> Maybe (Key Tree)
hackageCabalTree HackageCabal
hc of
        Maybe (Key Tree)
Nothing -> Bool
-> ReaderT SqlBackend (RIO env) (Maybe Package)
-> ReaderT SqlBackend (RIO env) (Maybe Package)
forall a. HasCallStack => Bool -> a -> a
assert Bool
False (ReaderT SqlBackend (RIO env) (Maybe Package)
 -> ReaderT SqlBackend (RIO env) (Maybe Package))
-> ReaderT SqlBackend (RIO env) (Maybe Package)
-> ReaderT SqlBackend (RIO env) (Maybe Package)
forall a b. (a -> b) -> a -> b
$ Maybe Package -> ReaderT SqlBackend (RIO env) (Maybe Package)
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Package
forall a. Maybe a
Nothing
        Just Key Tree
tid -> Package -> Maybe Package
forall a. a -> Maybe a
Just (Package -> Maybe Package)
-> ReaderT SqlBackend (RIO env) Package
-> ReaderT SqlBackend (RIO env) (Maybe Package)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawPackageLocationImmutable
-> Key Tree -> ReaderT SqlBackend (RIO env) Package
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 <- ReaderT SqlBackend (RIO env) UTCTime
forall (m :: * -> *). MonadIO m => m UTCTime
getCurrentTime
  Maybe (Entity Tree)
ment <- TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
forall env.
TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
getTreeForKey TreeKey
treeKey'
  Maybe (Entity Tree)
-> (Entity Tree -> ReaderT SqlBackend (RIO env) ())
-> ReaderT SqlBackend (RIO env) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (Entity Tree)
ment ((Entity Tree -> ReaderT SqlBackend (RIO env) ())
 -> ReaderT SqlBackend (RIO env) ())
-> (Entity Tree -> ReaderT SqlBackend (RIO env) ())
-> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ \Entity Tree
ent -> ArchiveCache -> ReaderT SqlBackend (RIO env) ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m ()
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend,
 SafeToInsert record) =>
record -> ReaderT SqlBackend 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 = Entity Tree -> Key Tree
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 = (Entity ArchiveCache -> (SHA256, FileSize, Key Tree))
-> [Entity ArchiveCache] -> [(SHA256, FileSize, Key Tree)]
forall a b. (a -> b) -> [a] -> [b]
map Entity ArchiveCache -> (SHA256, FileSize, Key Tree)
go ([Entity ArchiveCache] -> [(SHA256, FileSize, Key Tree)])
-> ReaderT SqlBackend (RIO env) [Entity ArchiveCache]
-> ReaderT SqlBackend (RIO env) [(SHA256, FileSize, Key Tree)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Filter ArchiveCache]
-> [SelectOpt ArchiveCache]
-> ReaderT SqlBackend (RIO env) [Entity ArchiveCache]
forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Entity record]
selectList
  [ EntityField ArchiveCache Text
forall typ. (typ ~ Text) => EntityField ArchiveCache typ
ArchiveCacheUrl EntityField ArchiveCache Text -> Text -> Filter ArchiveCache
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Text
url
  , EntityField ArchiveCache Text
forall typ. (typ ~ Text) => EntityField ArchiveCache typ
ArchiveCacheSubdir EntityField ArchiveCache Text -> Text -> Filter ArchiveCache
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Text
subdir
  ]
  [EntityField ArchiveCache UTCTime -> SelectOpt ArchiveCache
forall record typ. EntityField record typ -> SelectOpt record
Desc EntityField ArchiveCache UTCTime
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 <- ReaderT SqlBackend (RIO env) UTCTime
forall (m :: * -> *). MonadIO m => m UTCTime
getCurrentTime
  RepoCache -> ReaderT SqlBackend (RIO env) ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m ()
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend,
 SafeToInsert record) =>
record -> ReaderT SqlBackend 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 = (Entity RepoCache -> Key Tree)
-> Maybe (Entity RepoCache) -> Maybe (Key Tree)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RepoCache -> Key Tree
repoCacheTree (RepoCache -> Key Tree)
-> (Entity RepoCache -> RepoCache) -> Entity RepoCache -> Key Tree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity RepoCache -> RepoCache
forall record. Entity record -> record
entityVal) (Maybe (Entity RepoCache) -> Maybe (Key Tree))
-> ReaderT SqlBackend (RIO env) (Maybe (Entity RepoCache))
-> ReaderT SqlBackend (RIO env) (Maybe (Key Tree))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Filter RepoCache]
-> [SelectOpt RepoCache]
-> ReaderT SqlBackend (RIO env) (Maybe (Entity RepoCache))
forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m (Maybe (Entity record))
forall (m :: * -> *) record.
(MonadIO m, PersistRecordBackend record SqlBackend) =>
[Filter record]
-> [SelectOpt record]
-> ReaderT SqlBackend m (Maybe (Entity record))
selectFirst
  [ EntityField RepoCache Text
forall typ. (typ ~ Text) => EntityField RepoCache typ
RepoCacheUrl EntityField RepoCache Text -> Text -> Filter RepoCache
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Repo -> Text
repoUrl Repo
repo
  , EntityField RepoCache RepoType
forall typ. (typ ~ RepoType) => EntityField RepoCache typ
RepoCacheType EntityField RepoCache RepoType -> RepoType -> Filter RepoCache
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Repo -> RepoType
repoType Repo
repo
  , EntityField RepoCache Text
forall typ. (typ ~ Text) => EntityField RepoCache typ
RepoCacheCommit EntityField RepoCache Text -> Text -> Filter RepoCache
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Repo -> Text
repoCommit Repo
repo
  , EntityField RepoCache Text
forall typ. (typ ~ Text) => EntityField RepoCache typ
RepoCacheSubdir EntityField RepoCache Text -> Text -> Filter RepoCache
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Repo -> Text
repoSubdir Repo
repo
  ]
  [EntityField RepoCache UTCTime -> SelectOpt RepoCache
forall record typ. EntityField record typ -> SelectOpt record
Desc EntityField RepoCache UTCTime
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 <- PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
forall env.
PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
getPackageNameId PackageName
name
  Maybe (Entity PreferredVersions)
ment <- Unique PreferredVersions
-> ReaderT SqlBackend (RIO env) (Maybe (Entity PreferredVersions))
forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Unique record -> ReaderT SqlBackend m (Maybe (Entity record))
getBy (Unique PreferredVersions
 -> ReaderT SqlBackend (RIO env) (Maybe (Entity PreferredVersions)))
-> Unique PreferredVersions
-> ReaderT SqlBackend (RIO env) (Maybe (Entity PreferredVersions))
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 -> PreferredVersions -> ReaderT SqlBackend (RIO env) ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m ()
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend,
 SafeToInsert record) =>
record -> ReaderT SqlBackend m ()
insert_ PreferredVersions
      { preferredVersionsName :: Key PackageName
preferredVersionsName = Key PackageName
nameid
      , preferredVersionsPreferred :: Text
preferredVersionsPreferred = Text
p
      }
    Just (Entity Key PreferredVersions
pid PreferredVersions
_) -> Key PreferredVersions
-> [Update PreferredVersions] -> ReaderT SqlBackend (RIO env) ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> [Update record] -> ReaderT backend m ()
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Key record -> [Update record] -> ReaderT SqlBackend m ()
update Key PreferredVersions
pid [EntityField PreferredVersions Text
forall typ. (typ ~ Text) => EntityField PreferredVersions typ
PreferredVersionsPreferred EntityField PreferredVersions Text
-> Text -> Update PreferredVersions
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 <- PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
forall env.
PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
getPackageNameId PackageName
name
  (Entity PreferredVersions -> Text)
-> Maybe (Entity PreferredVersions) -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PreferredVersions -> Text
preferredVersionsPreferred (PreferredVersions -> Text)
-> (Entity PreferredVersions -> PreferredVersions)
-> Entity PreferredVersions
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity PreferredVersions -> PreferredVersions
forall record. Entity record -> record
entityVal) (Maybe (Entity PreferredVersions) -> Maybe Text)
-> ReaderT SqlBackend (RIO env) (Maybe (Entity PreferredVersions))
-> ReaderT SqlBackend (RIO env) (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Unique PreferredVersions
-> ReaderT SqlBackend (RIO env) (Maybe (Entity PreferredVersions))
forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Unique record -> ReaderT SqlBackend 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 <- [Filter PackageName]
-> [SelectOpt PackageName]
-> ReaderT
     SqlBackend
     (RIO env)
     (Acquire
        (ConduitM
           () (Entity PackageName) (ReaderT SqlBackend (RIO env)) ()))
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 ()))
forall record (m1 :: * -> *) (m2 :: * -> *).
(PersistRecordBackend record SqlBackend, MonadIO m1, MonadIO m2) =>
[Filter record]
-> [SelectOpt record]
-> ReaderT
     SqlBackend m1 (Acquire (ConduitM () (Entity record) m2 ()))
selectSourceRes [] []
  Acquire
  (ConduitM
     () (Entity PackageName) (ReaderT SqlBackend (RIO env)) ())
-> (ConduitM
      () (Entity PackageName) (ReaderT SqlBackend (RIO env)) ()
    -> ReaderT SqlBackend (RIO env) a)
-> ReaderT SqlBackend (RIO env) a
forall (m :: * -> *) a b.
MonadUnliftIO m =>
Acquire a -> (a -> m b) -> m b
with Acquire
  (ConduitM
     () (Entity PackageName) (ReaderT SqlBackend (RIO env)) ())
acqSrc ((ConduitM
    () (Entity PackageName) (ReaderT SqlBackend (RIO env)) ()
  -> ReaderT SqlBackend (RIO env) a)
 -> ReaderT SqlBackend (RIO env) a)
-> (ConduitM
      () (Entity PackageName) (ReaderT SqlBackend (RIO env)) ()
    -> ReaderT SqlBackend (RIO env) a)
-> ReaderT SqlBackend (RIO env) a
forall a b. (a -> b) -> a -> b
$ \ConduitM () (Entity PackageName) (ReaderT SqlBackend (RIO env)) ()
src -> ConduitT () Void (ReaderT SqlBackend (RIO env)) a
-> ReaderT SqlBackend (RIO env) a
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit
    (ConduitT () Void (ReaderT SqlBackend (RIO env)) a
 -> ReaderT SqlBackend (RIO env) a)
-> ConduitT () Void (ReaderT SqlBackend (RIO env)) a
-> ReaderT SqlBackend (RIO env) a
forall a b. (a -> b) -> a -> b
$ ConduitM () (Entity PackageName) (ReaderT SqlBackend (RIO env)) ()
src
   ConduitM () (Entity PackageName) (ReaderT SqlBackend (RIO env)) ()
-> ConduitT
     (Entity PackageName) Void (ReaderT SqlBackend (RIO env)) a
-> ConduitT () Void (ReaderT SqlBackend (RIO env)) a
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (Entity PackageName
 -> ReaderT SqlBackend (RIO env) (Maybe PackageName))
-> ConduitT
     (Entity PackageName)
     (Element (Maybe PackageName))
     (ReaderT SqlBackend (RIO env))
     ()
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
   ConduitT
  (Entity PackageName) PackageName (ReaderT SqlBackend (RIO env)) ()
-> ConduitT PackageName Void (ReaderT SqlBackend (RIO env)) a
-> ConduitT
     (Entity PackageName) Void (ReaderT SqlBackend (RIO env)) a
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 <- Key PackageName -> ReaderT SqlBackend (RIO env) Bool
forall {backend} {m :: * -> *}.
(BaseBackend backend ~ SqlBackend, MonadIO m,
 PersistQueryRead backend) =>
Key PackageName -> ReaderT backend m Bool
checkOnHackage Key PackageName
nameid
        Maybe PackageName
-> ReaderT SqlBackend (RIO env) (Maybe PackageName)
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe PackageName
 -> ReaderT SqlBackend (RIO env) (Maybe PackageName))
-> Maybe PackageName
-> ReaderT SqlBackend (RIO env) (Maybe PackageName)
forall a b. (a -> b) -> a -> b
$ if Bool
onHackage then PackageName -> Maybe PackageName
forall a. a -> Maybe a
Just PackageName
name else Maybe PackageName
forall a. Maybe a
Nothing
    | Bool
otherwise = Maybe PackageName
-> ReaderT SqlBackend (RIO env) (Maybe PackageName)
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe PackageName
forall a. Maybe a
Nothing

  checkOnHackage :: Key PackageName -> ReaderT backend m Bool
checkOnHackage Key PackageName
nameid = do
    Int
cnt <- [Filter HackageCabal] -> ReaderT backend m Int
forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m Int
forall (m :: * -> *) record.
(MonadIO m, PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m Int
count [EntityField HackageCabal (Key PackageName)
forall typ. (typ ~ Key PackageName) => EntityField HackageCabal typ
HackageCabalName EntityField HackageCabal (Key PackageName)
-> Key PackageName -> Filter HackageCabal
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key PackageName
nameid]
    Bool -> ReaderT backend m Bool
forall a. a -> ReaderT backend m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> ReaderT backend m Bool) -> Bool -> ReaderT backend m Bool
forall a b. (a -> b) -> a -> b
$ Int
cnt Int -> Int -> Bool
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
  Path Abs Dir -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir -> RIO env ()
hpack Path Abs Dir
pkgDir
  [Path Abs File]
files <- (Path Abs File -> Bool) -> [Path Abs File] -> [Path Abs File]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> String -> Bool) -> String -> String -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> String -> Bool
hasExtension String
"cabal" (String -> Bool)
-> (Path Abs File -> String) -> Path Abs File -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> String
forall b t. Path b t -> String
toFilePath) ([Path Abs File] -> [Path Abs File])
-> (([Path Abs Dir], [Path Abs File]) -> [Path Abs File])
-> ([Path Abs Dir], [Path Abs File])
-> [Path Abs File]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Path Abs Dir], [Path Abs File]) -> [Path Abs File]
forall a b. (a, b) -> b
snd
       (([Path Abs Dir], [Path Abs File]) -> [Path Abs File])
-> RIO env ([Path Abs Dir], [Path Abs File])
-> RIO env [Path Abs File]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Abs Dir -> RIO env ([Path Abs Dir], [Path Abs File])
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 (Path Abs File -> Bool) -> [Path Abs File] -> [Path Abs File]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Path Abs File -> Bool) -> Path Abs File -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isHidden (String -> Bool)
-> (Path Abs File -> String) -> Path Abs File -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Rel File -> String
fromRelFile (Path Rel File -> String)
-> (Path Abs File -> Path Rel File) -> Path Abs File -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> Path Rel File
forall b. Path b File -> Path Rel File
filename) [Path Abs File]
files of
    [] -> PantryException -> RIO env (PackageName, Path Abs File)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env (PackageName, Path Abs File))
-> PantryException -> RIO env (PackageName, Path Abs File)
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> PantryException
P.NoCabalFileFound Path Abs Dir
pkgDir
    [Path Abs File
x] -> RIO env (PackageName, Path Abs File)
-> (PackageName -> RIO env (PackageName, Path Abs File))
-> Maybe PackageName
-> RIO env (PackageName, Path Abs File)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      (PantryException -> RIO env (PackageName, Path Abs File)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env (PackageName, Path Abs File))
-> PantryException -> RIO env (PackageName, Path Abs File)
forall a b. (a -> b) -> a -> b
$ Path Abs File -> PantryException
P.InvalidCabalFilePath Path Abs File
x)
      (\PackageName
pn -> (PackageName, Path Abs File)
-> RIO env (PackageName, Path Abs File)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageName
pn, Path Abs File
x)) (Maybe PackageName -> RIO env (PackageName, Path Abs File))
-> Maybe PackageName -> RIO env (PackageName, Path Abs File)
forall a b. (a -> b) -> a -> b
$
        String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripSuffix String
".cabal" (Path Rel File -> String
forall b t. Path b t -> String
toFilePath (Path Abs File -> Path Rel File
forall b. Path b File -> Path Rel File
filename Path Abs File
x)) Maybe String -> (String -> Maybe PackageName) -> Maybe PackageName
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        String -> Maybe PackageName
P.parsePackageName
    Path Abs File
_:[Path Abs File]
_ -> PantryException -> RIO env (PackageName, Path Abs File)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env (PackageName, Path Abs File))
-> PantryException -> RIO env (PackageName, Path Abs File)
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 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"." String -> ShowS
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 <- RIO env (Path Abs Dir)
-> ReaderT SqlBackend (RIO env) (Path Abs Dir)
forall (m :: * -> *) a. Monad m => m a -> ReaderT SqlBackend m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RIO env (Path Abs Dir)
 -> ReaderT SqlBackend (RIO env) (Path Abs Dir))
-> RIO env (Path Abs Dir)
-> ReaderT SqlBackend (RIO env) (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ do
    Path Abs Dir
tdir <- RIO env (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getTempDir
    Path Abs Dir -> String -> RIO env (Path Abs Dir)
forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> String -> m (Path Abs Dir)
createTempDir Path Abs Dir
tdir String
"hpack-pkg-dir"
  RawPackageLocationImmutable
-> Path Abs Dir -> Tree -> ReaderT SqlBackend (RIO env) ()
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) <- RIO env (PackageName, Path Abs File)
-> ReaderT SqlBackend (RIO env) (PackageName, Path Abs File)
forall (m :: * -> *) a. Monad m => m a -> ReaderT SqlBackend m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RIO env (PackageName, Path Abs File)
 -> ReaderT SqlBackend (RIO env) (PackageName, Path Abs File))
-> RIO env (PackageName, Path Abs File)
-> ReaderT SqlBackend (RIO env) (PackageName, Path Abs File)
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> RIO env (PackageName, Path Abs File)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir -> RIO env (PackageName, Path Abs File)
findOrGenerateCabalFile Path Abs Dir
tmpDir
  !ByteString
bs <- RIO env ByteString -> ReaderT SqlBackend (RIO env) ByteString
forall (m :: * -> *) a. Monad m => m a -> ReaderT SqlBackend m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RIO env ByteString -> ReaderT SqlBackend (RIO env) ByteString)
-> RIO env ByteString -> ReaderT SqlBackend (RIO env) ByteString
forall a b. (a -> b) -> a -> b
$ String -> RIO env ByteString
forall (m :: * -> *). MonadIO m => String -> m ByteString
B.readFile (Path Abs File -> String
fromAbsFile Path Abs File
cfile)
  RIO env () -> ReaderT SqlBackend (RIO env) ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT SqlBackend m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RIO env () -> ReaderT SqlBackend (RIO env) ())
-> RIO env () -> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
removeDirRecur Path Abs Dir
tmpDir
  (PackageName, ByteString)
-> ReaderT SqlBackend (RIO env) (PackageName, ByteString)
forall a. a -> ReaderT SqlBackend (RIO env) a
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 = String
-> (String -> RIO env (PackageName, ByteString))
-> RIO env (PackageName, ByteString)
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> (String -> m a) -> m a
withSystemTempDirectory String
"hpack-pkg-dir" ((String -> RIO env (PackageName, ByteString))
 -> RIO env (PackageName, ByteString))
-> (String -> RIO env (PackageName, ByteString))
-> RIO env (PackageName, ByteString)
forall a b. (a -> b) -> a -> b
$ \String
tmpdir -> do
  Path Abs Dir
tdir <- String -> RIO env (Path Abs Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs Dir)
parseAbsDir String
tmpdir
  ReaderT SqlBackend (RIO env) () -> RIO env ()
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) () -> RIO env ())
-> ReaderT SqlBackend (RIO env) () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable
-> Path Abs Dir -> Tree -> ReaderT SqlBackend (RIO env) ()
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) <- Path Abs Dir -> RIO env (PackageName, Path Abs File)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir -> RIO env (PackageName, Path Abs File)
findOrGenerateCabalFile Path Abs Dir
tdir
  ByteString
bs <- String -> RIO env ByteString
forall (m :: * -> *). MonadIO m => String -> m ByteString
B.readFile (Path Abs File -> String
fromAbsFile Path Abs File
cfile)
  (PackageName, ByteString) -> RIO env (PackageName, ByteString)
forall a. a -> RIO env a
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 (Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath -> String
dir) (P.TreeMap Map SafeFilePath TreeEntry
m) = do
  [(SafeFilePath, TreeEntry)]
-> ((SafeFilePath, TreeEntry) -> ReaderT SqlBackend (RIO env) ())
-> ReaderT SqlBackend (RIO env) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_  (Map SafeFilePath TreeEntry -> [(SafeFilePath, TreeEntry)]
forall k a. Map k a -> [(k, a)]
Map.toList Map SafeFilePath TreeEntry
m) (((SafeFilePath, TreeEntry) -> ReaderT SqlBackend (RIO env) ())
 -> ReaderT SqlBackend (RIO env) ())
-> ((SafeFilePath, TreeEntry) -> ReaderT SqlBackend (RIO env) ())
-> ReaderT SqlBackend (RIO env) ()
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)
    Bool -> String -> ReaderT SqlBackend (RIO env) ()
forall (m :: * -> *). MonadIO m => Bool -> String -> m ()
createDirectoryIfMissing Bool
True (String -> ReaderT SqlBackend (RIO env) ())
-> String -> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ ShowS
takeDirectory String
dest
    Maybe ByteString
mbs <- BlobKey -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
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

        PantryException -> ReaderT SqlBackend (RIO env) ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> ReaderT SqlBackend (RIO env) ())
-> PantryException -> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable
-> SafeFilePath -> BlobKey -> PantryException
P.TreeReferencesMissingBlob RawPackageLocationImmutable
rpli SafeFilePath
sfp BlobKey
blobKey
      Just ByteString
bs -> do
        String -> ByteString -> ReaderT SqlBackend (RIO env) ()
forall (m :: * -> *). MonadIO m => String -> ByteString -> m ()
B.writeFile String
dest ByteString
bs
        case FileType
ft of
          FileType
FTNormal -> () -> ReaderT SqlBackend (RIO env) ()
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          FileType
FTExecutable -> IO () -> ReaderT SqlBackend (RIO env) ()
forall a. IO a -> ReaderT SqlBackend (RIO env) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT SqlBackend (RIO env) ())
-> IO () -> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ do
            Permissions
perms <- String -> IO Permissions
forall (m :: * -> *). MonadIO m => String -> m Permissions
getPermissions String
dest
            String -> Permissions -> IO ()
forall (m :: * -> *). MonadIO m => String -> Permissions -> m ()
setPermissions String
dest (Permissions -> IO ()) -> Permissions -> IO ()
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 <- Text -> [PersistValue] -> ReaderT SqlBackend (RIO env) [Single Int]
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
    [] -> Int -> ReaderT SqlBackend (RIO env) Int
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0
    (Single Int
n):[Single Int]
_ ->
      Int -> ReaderT SqlBackend (RIO env) Int
forall a. a -> ReaderT SqlBackend (RIO env) a
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 =
  (Maybe (Entity SnapshotCache) -> Maybe (Key SnapshotCache))
-> ReaderT SqlBackend (RIO env) (Maybe (Entity SnapshotCache))
-> ReaderT SqlBackend (RIO env) (Maybe (Key SnapshotCache))
forall a b.
(a -> b)
-> ReaderT SqlBackend (RIO env) a -> ReaderT SqlBackend (RIO env) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Entity SnapshotCache -> Key SnapshotCache)
-> Maybe (Entity SnapshotCache) -> Maybe (Key SnapshotCache)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Entity SnapshotCache -> Key SnapshotCache
forall record. Entity record -> Key record
entityKey) (ReaderT SqlBackend (RIO env) (Maybe (Entity SnapshotCache))
 -> ReaderT SqlBackend (RIO env) (Maybe (Key SnapshotCache)))
-> (SnapshotCacheHash
    -> ReaderT SqlBackend (RIO env) (Maybe (Entity SnapshotCache)))
-> SnapshotCacheHash
-> ReaderT SqlBackend (RIO env) (Maybe (Key SnapshotCache))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unique SnapshotCache
-> ReaderT SqlBackend (RIO env) (Maybe (Entity SnapshotCache))
forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Unique record -> ReaderT SqlBackend m (Maybe (Entity record))
getBy (Unique SnapshotCache
 -> ReaderT SqlBackend (RIO env) (Maybe (Entity SnapshotCache)))
-> (SnapshotCacheHash -> Unique SnapshotCache)
-> SnapshotCacheHash
-> ReaderT SqlBackend (RIO env) (Maybe (Entity SnapshotCache))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SHA256 -> Unique SnapshotCache
UniqueSnapshotCache (SHA256 -> Unique SnapshotCache)
-> (SnapshotCacheHash -> SHA256)
-> SnapshotCacheHash
-> Unique SnapshotCache
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 =
  (Either (Entity SnapshotCache) (Key SnapshotCache)
 -> Key SnapshotCache)
-> ReaderT
     SqlBackend
     (RIO env)
     (Either (Entity SnapshotCache) (Key SnapshotCache))
-> ReaderT SqlBackend (RIO env) (Key SnapshotCache)
forall a b.
(a -> b)
-> ReaderT SqlBackend (RIO env) a -> ReaderT SqlBackend (RIO env) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Entity SnapshotCache -> Key SnapshotCache)
-> (Key SnapshotCache -> Key SnapshotCache)
-> Either (Entity SnapshotCache) (Key SnapshotCache)
-> Key SnapshotCache
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Entity SnapshotCache -> Key SnapshotCache
forall record. Entity record -> Key record
entityKey Key SnapshotCache -> Key SnapshotCache
forall a. a -> a
id) (ReaderT
   SqlBackend
   (RIO env)
   (Either (Entity SnapshotCache) (Key SnapshotCache))
 -> ReaderT SqlBackend (RIO env) (Key SnapshotCache))
-> (SnapshotCacheHash
    -> ReaderT
         SqlBackend
         (RIO env)
         (Either (Entity SnapshotCache) (Key SnapshotCache)))
-> SnapshotCacheHash
-> ReaderT SqlBackend (RIO env) (Key SnapshotCache)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapshotCache
-> ReaderT
     SqlBackend
     (RIO env)
     (Either (Entity SnapshotCache) (Key SnapshotCache))
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 (SnapshotCache
 -> ReaderT
      SqlBackend
      (RIO env)
      (Either (Entity SnapshotCache) (Key SnapshotCache)))
-> (SnapshotCacheHash -> SnapshotCache)
-> SnapshotCacheHash
-> ReaderT
     SqlBackend
     (RIO env)
     (Either (Entity SnapshotCache) (Key SnapshotCache))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SHA256 -> SnapshotCache
SnapshotCache (SHA256 -> SnapshotCache)
-> (SnapshotCacheHash -> SHA256)
-> SnapshotCacheHash
-> 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 =
  (Either (Entity ModuleName) (Key ModuleName) -> Key ModuleName)
-> ReaderT
     SqlBackend (RIO env) (Either (Entity ModuleName) (Key ModuleName))
-> ReaderT SqlBackend (RIO env) (Key ModuleName)
forall a b.
(a -> b)
-> ReaderT SqlBackend (RIO env) a -> ReaderT SqlBackend (RIO env) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Entity ModuleName -> Key ModuleName)
-> (Key ModuleName -> Key ModuleName)
-> Either (Entity ModuleName) (Key ModuleName)
-> Key ModuleName
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Entity ModuleName -> Key ModuleName
forall record. Entity record -> Key record
entityKey Key ModuleName -> Key ModuleName
forall a. a -> a
id) (ReaderT
   SqlBackend (RIO env) (Either (Entity ModuleName) (Key ModuleName))
 -> ReaderT SqlBackend (RIO env) (Key ModuleName))
-> (ModuleName
    -> ReaderT
         SqlBackend (RIO env) (Either (Entity ModuleName) (Key ModuleName)))
-> ModuleName
-> ReaderT SqlBackend (RIO env) (Key ModuleName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName
-> ReaderT
     SqlBackend (RIO env) (Either (Entity ModuleName) (Key ModuleName))
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 (ModuleName
 -> ReaderT
      SqlBackend (RIO env) (Either (Entity ModuleName) (Key ModuleName)))
-> (ModuleName -> ModuleName)
-> ModuleName
-> ReaderT
     SqlBackend (RIO env) (Either (Entity ModuleName) (Key ModuleName))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleNameP -> ModuleName
ModuleName (ModuleNameP -> ModuleName)
-> (ModuleName -> 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 =
  [(PackageName, Set ModuleName)]
-> ((PackageName, Set ModuleName)
    -> ReaderT SqlBackend (RIO env) ())
-> ReaderT SqlBackend (RIO env) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map PackageName (Set ModuleName) -> [(PackageName, Set ModuleName)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName (Set ModuleName)
packageModules) (((PackageName, Set ModuleName) -> ReaderT SqlBackend (RIO env) ())
 -> ReaderT SqlBackend (RIO env) ())
-> ((PackageName, Set ModuleName)
    -> ReaderT SqlBackend (RIO env) ())
-> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ \(PackageName
pn, Set ModuleName
modules) -> do
    Key PackageName
package <- PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
forall env.
PackageName -> ReaderT SqlBackend (RIO env) (Key PackageName)
getPackageNameId PackageName
pn
    Set ModuleName
-> (ModuleName -> ReaderT SqlBackend (RIO env) ())
-> ReaderT SqlBackend (RIO env) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Set ModuleName
modules ((ModuleName -> ReaderT SqlBackend (RIO env) ())
 -> ReaderT SqlBackend (RIO env) ())
-> (ModuleName -> ReaderT SqlBackend (RIO env) ())
-> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ \ModuleName
m -> do
      Key ModuleName
moduleName <- ModuleName -> ReaderT SqlBackend (RIO env) (Key ModuleName)
forall env.
ModuleName -> ReaderT SqlBackend (RIO env) (Key ModuleName)
getModuleNameId ModuleName
m
      PackageExposedModule -> ReaderT SqlBackend (RIO env) ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m ()
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend,
 SafeToInsert record) =>
record -> ReaderT SqlBackend 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 =
  (Single PackageNameP -> PackageName)
-> [Single PackageNameP] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map Single PackageNameP -> PackageName
go ([Single PackageNameP] -> [PackageName])
-> ReaderT SqlBackend (RIO env) [Single PackageNameP]
-> ReaderT SqlBackend (RIO env) [PackageName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> [PersistValue]
-> ReaderT SqlBackend (RIO env) [Single PackageNameP]
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"
    [ ModuleNameP -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue (ModuleName -> ModuleNameP
P.ModuleNameP ModuleName
mName)
    , Key SnapshotCache -> PersistValue
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
(Int -> LoadCachedTreeException -> ShowS)
-> (LoadCachedTreeException -> String)
-> ([LoadCachedTreeException] -> ShowS)
-> Show LoadCachedTreeException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LoadCachedTreeException -> ShowS
showsPrec :: Int -> LoadCachedTreeException -> ShowS
$cshow :: LoadCachedTreeException -> String
show :: LoadCachedTreeException -> String
$cshowList :: [LoadCachedTreeException] -> ShowS
showList :: [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) =
  ReaderT SqlBackend (RIO env) CachedTree
-> ReaderT
     SqlBackend (RIO env) (Either LoadCachedTreeException CachedTree)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (ReaderT SqlBackend (RIO env) CachedTree
 -> ReaderT
      SqlBackend (RIO env) (Either LoadCachedTreeException CachedTree))
-> ReaderT SqlBackend (RIO env) CachedTree
-> ReaderT
     SqlBackend (RIO env) (Either LoadCachedTreeException CachedTree)
forall a b. (a -> b) -> a -> b
$ Map SafeFilePath (TreeEntry, Key Blob) -> CachedTree
CachedTreeMap (Map SafeFilePath (TreeEntry, Key Blob) -> CachedTree)
-> ReaderT
     SqlBackend (RIO env) (Map SafeFilePath (TreeEntry, Key Blob))
-> ReaderT SqlBackend (RIO env) CachedTree
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TreeEntry -> ReaderT SqlBackend (RIO env) (TreeEntry, Key Blob))
-> Map SafeFilePath TreeEntry
-> ReaderT
     SqlBackend (RIO env) (Map SafeFilePath (TreeEntry, Key Blob))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Map SafeFilePath a -> f (Map SafeFilePath 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, ) (Key Blob -> (TreeEntry, Key Blob))
-> ReaderT SqlBackend (RIO env) (Key Blob)
-> ReaderT SqlBackend (RIO env) (TreeEntry, Key Blob)
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 <- SHA256 -> ReaderT SqlBackend (RIO env) (Maybe (Key Blob))
forall env.
SHA256 -> ReaderT SqlBackend (RIO env) (Maybe (Key Blob))
loadBlobBySHA SHA256
sha
    case Maybe (Key Blob)
mbid of
      Maybe (Key Blob)
Nothing -> LoadCachedTreeException -> ReaderT SqlBackend (RIO env) (Key Blob)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (LoadCachedTreeException
 -> ReaderT SqlBackend (RIO env) (Key Blob))
-> LoadCachedTreeException
-> ReaderT SqlBackend (RIO env) (Key Blob)
forall a b. (a -> b) -> a -> b
$ BlobKey -> LoadCachedTreeException
MissingBlob BlobKey
blobKey
      Just Key Blob
bid -> Key Blob -> ReaderT SqlBackend (RIO env) (Key Blob)
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Key Blob
bid