{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Content addressable Haskell package management, providing for
-- secure, reproducible acquisition of Haskell package contents and
-- metadata.
--
-- @since 0.1.0.0
module Pantry
  ( -- * Running
    PantryConfig
  , HackageSecurityConfig (..)
  , defaultHackageSecurityConfig
  , defaultCasaRepoPrefix
  , defaultCasaMaxPerRequest
  , defaultSnapshotLocation
  , HasPantryConfig (..)
  , withPantryConfig
  , HpackExecutable (..)

    -- ** Convenience
  , PantryApp
  , runPantryApp
  , runPantryAppClean
  , runPantryAppWith
  , hpackExecutableL

    -- * Types

    -- ** Exceptions
  , PantryException (..)

    -- ** Cabal types
  , PackageName
  , Version
  , FlagName
  , PackageIdentifier (..)

    -- ** Files
  , FileSize (..)
  , RelFilePath (..)
  , ResolvedPath (..)
  , Unresolved

    -- ** Cryptography
  , SHA256
  , TreeKey (..)
  , BlobKey (..)

    -- ** Packages
  , RawPackageMetadata (..)
  , PackageMetadata (..)
  , Package (..)

    -- ** Hackage
  , CabalFileInfo (..)
  , Revision (..)
  , PackageIdentifierRevision (..)
  , UsePreferredVersions (..)

    -- ** Archives
  , RawArchive (..)
  , Archive (..)
  , ArchiveLocation (..)

    -- ** Repos
  , Repo (..)
  , RepoType (..)
  , withRepo

    -- ** Package location
  , RawPackageLocation (..)
  , PackageLocation (..)
  , toRawPL
  , RawPackageLocationImmutable (..)
  , PackageLocationImmutable (..)

    -- ** Snapshots
  , RawSnapshotLocation (..)
  , SnapshotLocation (..)
  , toRawSL
  , RawSnapshot (..)
  , Snapshot (..)
  , RawSnapshotPackage (..)
  , SnapshotPackage (..)
  , RawSnapshotLayer (..)
  , SnapshotLayer (..)
  , toRawSnapshotLayer
  , WantedCompiler (..)
  , SnapName (..)
  , snapshotLocation

    -- * Loading values
  , resolvePaths
  , loadPackageRaw
  , tryLoadPackageRawViaCasa
  , loadPackage
  , loadRawSnapshotLayer
  , loadSnapshotLayer
  , loadSnapshot
  , loadAndCompleteSnapshot
  , loadAndCompleteSnapshotRaw
  , CompletedSL (..)
  , CompletedPLI (..)
  , addPackagesToSnapshot
  , AddPackagesConfig (..)

    -- * Completion functions
  , CompletePackageLocation (..)
  , completePackageLocation
  , completeSnapshotLocation
  , warnMissingCabalFile

    -- * Parsers
  , parseWantedCompiler
  , parseSnapName
  , parseRawSnapshotLocation
  , parsePackageIdentifierRevision
  , parseHackageText

    -- ** Cabal values
  , parsePackageIdentifier
  , parsePackageName
  , parsePackageNameThrowing
  , parseFlagName
  , parseVersion
  , parseVersionThrowing

    -- * Cabal helpers
  , packageIdentifierString
  , packageNameString
  , flagNameString
  , versionString
  , moduleNameString
  , CabalString (..)
  , toCabalStringMap
  , unCabalStringMap
  , gpdPackageIdentifier
  , gpdPackageName
  , gpdVersion

    -- * Package location
  , fetchPackages
  , unpackPackageLocationRaw
  , unpackPackageLocation
  , getPackageLocationName
  , getRawPackageLocationIdent
  , packageLocationIdent
  , packageLocationVersion
  , getRawPackageLocationTreeKey
  , getPackageLocationTreeKey

    -- * Cabal files
  , loadCabalFileRaw
  , loadCabalFile
  , loadCabalFileRawImmutable
  , loadCabalFileImmutable
  , loadCabalFilePath
  , findOrGenerateCabalFile
  , PrintWarnings (..)

    -- * Hackage index
  , updateHackageIndex
  , DidUpdateOccur (..)
  , RequireHackageIndex (..)
  , hackageIndexTarballL
  , getHackagePackageVersions
  , getLatestHackageVersion
  , getLatestHackageLocation
  , getLatestHackageRevision
  , getHackageTypoCorrections
  , loadGlobalHints
  , partitionReplacedDependencies
    -- * Snapshot cache
  , SnapshotCacheHash (..)
  , withSnapshotCache
  ) where

import Database.Persist (entityKey)
import RIO
import Conduit
import Control.Arrow (right)
import Control.Monad.State.Strict (State, execState, get, modify')
import qualified RIO.Map as Map
import qualified RIO.Set as Set
import qualified RIO.ByteString as B
import qualified RIO.Text as T
import qualified RIO.List as List
import qualified RIO.FilePath as FilePath
import Pantry.Archive
import Pantry.Casa
import Casa.Client (thParserCasaRepo, CasaRepoPrefix)
import Pantry.Repo
import qualified Pantry.SHA256 as SHA256
import Pantry.Storage hiding (TreeEntry, PackageName, Version)
import Pantry.Tree
import Pantry.Types as P
import Pantry.Hackage
import Path (Path, Abs, File, toFilePath, Dir, (</>), filename, parseAbsDir, parent, parseRelFile)
import Path.IO (doesFileExist, resolveDir', listDir)
import Distribution.PackageDescription (GenericPackageDescription, FlagName)
import qualified Distribution.PackageDescription as D
import Distribution.Parsec (PWarning (..), showPos)
import qualified Hpack
import qualified Hpack.Config as Hpack
import Network.HTTP.Download
import RIO.PrettyPrint
import RIO.PrettyPrint.StylesUpdate
import RIO.Process
import RIO.Directory (getAppUserDataDirectory)
import qualified Data.Yaml as Yaml
import Pantry.Internal.AesonExtended (WithJSONWarnings (..), Value)
import Data.Aeson.Types (parseEither)
import Data.Monoid (Endo (..))
import Pantry.HTTP
import Data.Char (isHexDigit)
import Data.Time (getCurrentTime, diffUTCTime)

-- | Create a new 'PantryConfig' with the given settings.
--
-- For something easier to use in simple cases, see 'runPantryApp'.
--
-- @since 0.1.0.0
withPantryConfig
  :: HasLogFunc env
  => Path Abs Dir
  -- ^ pantry root directory, where the SQLite database and Hackage
  -- downloads are kept.
  -> HackageSecurityConfig
  -- ^ Hackage configuration. You probably want
  -- 'defaultHackageSecurityConfig'.
  -> HpackExecutable
  -- ^ When converting an hpack @package.yaml@ file to a cabal file,
  -- what version of hpack should we use?
  -> Int
  -- ^ Maximum connection count
  -> CasaRepoPrefix
  -- ^ The casa pull URL e.g. https://casa.fpcomplete.com/v1/pull.
  -> Int
  -- ^ Max casa keys to pull per request.
  -> (SnapName -> RawSnapshotLocation)
  -- ^ The location of snapshot synonyms
  -> (PantryConfig -> RIO env a)
  -- ^ What to do with the config
  -> RIO env a
withPantryConfig :: Path Abs Dir
-> HackageSecurityConfig
-> HpackExecutable
-> Int
-> CasaRepoPrefix
-> Int
-> (SnapName -> RawSnapshotLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
withPantryConfig Path Abs Dir
root HackageSecurityConfig
hsc HpackExecutable
he Int
count CasaRepoPrefix
pullURL Int
maxPerRequest SnapName -> RawSnapshotLocation
snapLoc PantryConfig -> RIO env a
inner = do
  env
env <- RIO env env
forall r (m :: * -> *). MonadReader r m => m r
ask
  Path Rel File
pantryRelFile <- FilePath -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel File)
parseRelFile FilePath
"pantry.sqlite3"
  -- Silence persistent's logging output, which is really noisy
  LogFunc -> RIO LogFunc a -> RIO env a
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO (LogFunc
forall a. Monoid a => a
mempty :: LogFunc) (RIO LogFunc a -> RIO env a) -> RIO LogFunc a -> RIO env a
forall a b. (a -> b) -> a -> b
$ Path Abs File -> (Storage -> RIO LogFunc a) -> RIO LogFunc a
forall env a.
HasLogFunc env =>
Path Abs File -> (Storage -> RIO env a) -> RIO env a
initStorage (Path Abs Dir
root Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
pantryRelFile) ((Storage -> RIO LogFunc a) -> RIO LogFunc a)
-> (Storage -> RIO LogFunc a) -> RIO LogFunc a
forall a b. (a -> b) -> a -> b
$ \Storage
storage -> env -> RIO env a -> RIO LogFunc a
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO env
env (RIO env a -> RIO LogFunc a) -> RIO env a -> RIO LogFunc a
forall a b. (a -> b) -> a -> b
$ do
    MVar Bool
ur <- Bool -> RIO env (MVar Bool)
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar Bool
True
    IORef (Map RawPackageLocationImmutable GenericPackageDescription)
ref1 <- Map RawPackageLocationImmutable GenericPackageDescription
-> RIO
     env
     (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Map RawPackageLocationImmutable GenericPackageDescription
forall a. Monoid a => a
mempty
    IORef
  (Map
     (Path Abs Dir)
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File))
ref2 <- Map
  (Path Abs Dir)
  (PrintWarnings -> IO GenericPackageDescription, PackageName,
   Path Abs File)
-> RIO
     env
     (IORef
        (Map
           (Path Abs Dir)
           (PrintWarnings -> IO GenericPackageDescription, PackageName,
            Path Abs File)))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Map
  (Path Abs Dir)
  (PrintWarnings -> IO GenericPackageDescription, PackageName,
   Path Abs File)
forall a. Monoid a => a
mempty
    PantryConfig -> RIO env a
inner PantryConfig :: HackageSecurityConfig
-> HpackExecutable
-> Path Abs Dir
-> Storage
-> MVar Bool
-> IORef
     (Map RawPackageLocationImmutable GenericPackageDescription)
-> IORef
     (Map
        (Path Abs Dir)
        (PrintWarnings -> IO GenericPackageDescription, PackageName,
         Path Abs File))
-> Int
-> CasaRepoPrefix
-> Int
-> (SnapName -> RawSnapshotLocation)
-> PantryConfig
PantryConfig
      { pcHackageSecurity :: HackageSecurityConfig
pcHackageSecurity = HackageSecurityConfig
hsc
      , pcHpackExecutable :: HpackExecutable
pcHpackExecutable = HpackExecutable
he
      , pcRootDir :: Path Abs Dir
pcRootDir = Path Abs Dir
root
      , pcStorage :: Storage
pcStorage = Storage
storage
      , pcUpdateRef :: MVar Bool
pcUpdateRef = MVar Bool
ur
      , pcConnectionCount :: Int
pcConnectionCount = Int
count
      , pcParsedCabalFilesRawImmutable :: IORef (Map RawPackageLocationImmutable GenericPackageDescription)
pcParsedCabalFilesRawImmutable = IORef (Map RawPackageLocationImmutable GenericPackageDescription)
ref1
      , pcParsedCabalFilesMutable :: IORef
  (Map
     (Path Abs Dir)
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File))
pcParsedCabalFilesMutable = IORef
  (Map
     (Path Abs Dir)
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File))
ref2
      , pcCasaRepoPrefix :: CasaRepoPrefix
pcCasaRepoPrefix = CasaRepoPrefix
pullURL
      , pcCasaMaxPerRequest :: Int
pcCasaMaxPerRequest = Int
maxPerRequest
      , pcSnapshotLocation :: SnapName -> RawSnapshotLocation
pcSnapshotLocation = SnapName -> RawSnapshotLocation
snapLoc
      }

-- | Default pull URL for Casa.
--
-- @since 0.1.1.1
defaultCasaRepoPrefix :: CasaRepoPrefix
defaultCasaRepoPrefix :: CasaRepoPrefix
defaultCasaRepoPrefix = $(thParserCasaRepo "https://casa.fpcomplete.com")

-- | Default max keys to pull per request.
--
-- @since 0.1.1.1
defaultCasaMaxPerRequest :: Int
defaultCasaMaxPerRequest :: Int
defaultCasaMaxPerRequest = Int
1280

-- | Default 'HackageSecurityConfig' value using the official Hackage server.
--
-- @since 0.1.0.0
defaultHackageSecurityConfig :: HackageSecurityConfig
defaultHackageSecurityConfig :: HackageSecurityConfig
defaultHackageSecurityConfig = HackageSecurityConfig :: [Text] -> Int -> Text -> Bool -> HackageSecurityConfig
HackageSecurityConfig
  { hscKeyIds :: [Text]
hscKeyIds =
      [ Text
"0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d"
      , Text
"1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42"
      , Text
"280b10153a522681163658cb49f632cde3f38d768b736ddbc901d99a1a772833"
      , Text
"2a96b1889dc221c17296fcc2bb34b908ca9734376f0f361660200935916ef201"
      , Text
"2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3"
      , Text
"51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921"
      , Text
"772e9f4c7db33d251d5c6e357199c819e569d130857dc225549b40845ff0890d"
      , Text
"aa315286e6ad281ad61182235533c41e806e5a787e0b6d1e7eef3f09d137d2e9"
      , Text
"fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0"
      ]
  , hscKeyThreshold :: Int
hscKeyThreshold = Int
3
  , hscDownloadPrefix :: Text
hscDownloadPrefix = Text
"https://hackage.haskell.org/"
  , hscIgnoreExpiry :: Bool
hscIgnoreExpiry = Bool
False
  }

-- | Returns the latest version of the given package available from
-- Hackage.
--
-- @since 0.1.0.0
getLatestHackageVersion
  :: (HasPantryConfig env, HasLogFunc env)
  => RequireHackageIndex
  -> PackageName -- ^ package name
  -> UsePreferredVersions
  -> RIO env (Maybe PackageIdentifierRevision)
getLatestHackageVersion :: RequireHackageIndex
-> PackageName
-> UsePreferredVersions
-> RIO env (Maybe PackageIdentifierRevision)
getLatestHackageVersion RequireHackageIndex
req PackageName
name UsePreferredVersions
preferred =
  (((((Version, Map Revision BlobKey),
  Map Version (Map Revision BlobKey))
 -> (Version, Map Revision BlobKey))
-> Maybe
     ((Version, Map Revision BlobKey),
      Map Version (Map Revision BlobKey))
-> Maybe (Version, Map Revision BlobKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Version, Map Revision BlobKey),
 Map Version (Map Revision BlobKey))
-> (Version, Map Revision BlobKey)
forall a b. (a, b) -> a
fst (Maybe
   ((Version, Map Revision BlobKey),
    Map Version (Map Revision BlobKey))
 -> Maybe (Version, Map Revision BlobKey))
-> (Map Version (Map Revision BlobKey)
    -> Maybe
         ((Version, Map Revision BlobKey),
          Map Version (Map Revision BlobKey)))
-> Map Version (Map Revision BlobKey)
-> Maybe (Version, Map Revision BlobKey)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Version (Map Revision BlobKey)
-> Maybe
     ((Version, Map Revision BlobKey),
      Map Version (Map Revision BlobKey))
forall k a. Map k a -> Maybe ((k, a), Map k a)
Map.maxViewWithKey) (Map Version (Map Revision BlobKey)
 -> Maybe (Version, Map Revision BlobKey))
-> ((Version, Map Revision BlobKey)
    -> Maybe PackageIdentifierRevision)
-> Map Version (Map Revision BlobKey)
-> Maybe PackageIdentifierRevision
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (Version, Map Revision BlobKey) -> Maybe PackageIdentifierRevision
forall k.
(Version, Map k BlobKey) -> Maybe PackageIdentifierRevision
go) (Map Version (Map Revision BlobKey)
 -> Maybe PackageIdentifierRevision)
-> RIO env (Map Version (Map Revision BlobKey))
-> RIO env (Maybe PackageIdentifierRevision)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RequireHackageIndex
-> UsePreferredVersions
-> PackageName
-> RIO env (Map Version (Map Revision BlobKey))
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RequireHackageIndex
-> UsePreferredVersions
-> PackageName
-> RIO env (Map Version (Map Revision BlobKey))
getHackagePackageVersions RequireHackageIndex
req UsePreferredVersions
preferred PackageName
name
  where
    go :: (Version, Map k BlobKey) -> Maybe PackageIdentifierRevision
go (Version
version, Map k BlobKey
m) = do
      (k
_rev, BlobKey SHA256
sha FileSize
size) <- ((k, BlobKey), Map k BlobKey) -> (k, BlobKey)
forall a b. (a, b) -> a
fst (((k, BlobKey), Map k BlobKey) -> (k, BlobKey))
-> Maybe ((k, BlobKey), Map k BlobKey) -> Maybe (k, BlobKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map k BlobKey -> Maybe ((k, BlobKey), Map k BlobKey)
forall k a. Map k a -> Maybe ((k, a), Map k a)
Map.maxViewWithKey Map k BlobKey
m
      PackageIdentifierRevision -> Maybe PackageIdentifierRevision
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageIdentifierRevision -> Maybe PackageIdentifierRevision)
-> PackageIdentifierRevision -> Maybe PackageIdentifierRevision
forall a b. (a -> b) -> a -> b
$ PackageName
-> Version -> CabalFileInfo -> PackageIdentifierRevision
PackageIdentifierRevision PackageName
name Version
version (CabalFileInfo -> PackageIdentifierRevision)
-> CabalFileInfo -> PackageIdentifierRevision
forall a b. (a -> b) -> a -> b
$ SHA256 -> Maybe FileSize -> CabalFileInfo
CFIHash SHA256
sha (Maybe FileSize -> CabalFileInfo)
-> Maybe FileSize -> CabalFileInfo
forall a b. (a -> b) -> a -> b
$ FileSize -> Maybe FileSize
forall a. a -> Maybe a
Just FileSize
size

-- | Returns location of the latest version of the given package available from
-- Hackage.
--
-- @since 0.1.0.0
getLatestHackageLocation
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => RequireHackageIndex
  -> PackageName -- ^ package name
  -> UsePreferredVersions
  -> RIO env (Maybe PackageLocationImmutable)
getLatestHackageLocation :: RequireHackageIndex
-> PackageName
-> UsePreferredVersions
-> RIO env (Maybe PackageLocationImmutable)
getLatestHackageLocation RequireHackageIndex
req PackageName
name UsePreferredVersions
preferred = do
  Maybe (Version, Map Revision BlobKey)
mversion <-
    (((Version, Map Revision BlobKey),
  Map Version (Map Revision BlobKey))
 -> (Version, Map Revision BlobKey))
-> Maybe
     ((Version, Map Revision BlobKey),
      Map Version (Map Revision BlobKey))
-> Maybe (Version, Map Revision BlobKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Version, Map Revision BlobKey),
 Map Version (Map Revision BlobKey))
-> (Version, Map Revision BlobKey)
forall a b. (a, b) -> a
fst (Maybe
   ((Version, Map Revision BlobKey),
    Map Version (Map Revision BlobKey))
 -> Maybe (Version, Map Revision BlobKey))
-> (Map Version (Map Revision BlobKey)
    -> Maybe
         ((Version, Map Revision BlobKey),
          Map Version (Map Revision BlobKey)))
-> Map Version (Map Revision BlobKey)
-> Maybe (Version, Map Revision BlobKey)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Version (Map Revision BlobKey)
-> Maybe
     ((Version, Map Revision BlobKey),
      Map Version (Map Revision BlobKey))
forall k a. Map k a -> Maybe ((k, a), Map k a)
Map.maxViewWithKey (Map Version (Map Revision BlobKey)
 -> Maybe (Version, Map Revision BlobKey))
-> RIO env (Map Version (Map Revision BlobKey))
-> RIO env (Maybe (Version, Map Revision BlobKey))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RequireHackageIndex
-> UsePreferredVersions
-> PackageName
-> RIO env (Map Version (Map Revision BlobKey))
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RequireHackageIndex
-> UsePreferredVersions
-> PackageName
-> RIO env (Map Version (Map Revision BlobKey))
getHackagePackageVersions RequireHackageIndex
req UsePreferredVersions
preferred PackageName
name
  let mVerCfKey :: Maybe (Version, BlobKey)
mVerCfKey = do
        (Version
version, Map Revision BlobKey
revisions) <- Maybe (Version, Map Revision BlobKey)
mversion
        (Revision
_rev, BlobKey
cfKey) <- ((Revision, BlobKey), Map Revision BlobKey) -> (Revision, BlobKey)
forall a b. (a, b) -> a
fst (((Revision, BlobKey), Map Revision BlobKey)
 -> (Revision, BlobKey))
-> Maybe ((Revision, BlobKey), Map Revision BlobKey)
-> Maybe (Revision, BlobKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Revision BlobKey
-> Maybe ((Revision, BlobKey), Map Revision BlobKey)
forall k a. Map k a -> Maybe ((k, a), Map k a)
Map.maxViewWithKey Map Revision BlobKey
revisions
        (Version, BlobKey) -> Maybe (Version, BlobKey)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Version
version, BlobKey
cfKey)

  Maybe (Version, BlobKey)
-> ((Version, BlobKey) -> RIO env PackageLocationImmutable)
-> RIO env (Maybe PackageLocationImmutable)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (Version, BlobKey)
mVerCfKey (((Version, BlobKey) -> RIO env PackageLocationImmutable)
 -> RIO env (Maybe PackageLocationImmutable))
-> ((Version, BlobKey) -> RIO env PackageLocationImmutable)
-> RIO env (Maybe PackageLocationImmutable)
forall a b. (a -> b) -> a -> b
$ \(Version
version, cfKey :: BlobKey
cfKey@(BlobKey SHA256
sha FileSize
size)) -> do
    let pir :: PackageIdentifierRevision
pir = PackageName
-> Version -> CabalFileInfo -> PackageIdentifierRevision
PackageIdentifierRevision PackageName
name Version
version (SHA256 -> Maybe FileSize -> CabalFileInfo
CFIHash SHA256
sha (FileSize -> Maybe FileSize
forall a. a -> Maybe a
Just FileSize
size))
    TreeKey
treeKey' <- PackageIdentifierRevision -> RIO env TreeKey
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageIdentifierRevision -> RIO env TreeKey
getHackageTarballKey PackageIdentifierRevision
pir
    PackageLocationImmutable -> RIO env PackageLocationImmutable
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageLocationImmutable -> RIO env PackageLocationImmutable)
-> PackageLocationImmutable -> RIO env PackageLocationImmutable
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> BlobKey -> TreeKey -> PackageLocationImmutable
PLIHackage (PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version) BlobKey
cfKey TreeKey
treeKey'

-- | Returns the latest revision of the given package version available from
-- Hackage.
--
-- @since 0.1.0.0
getLatestHackageRevision
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => RequireHackageIndex
  -> PackageName -- ^ package name
  -> Version
  -> RIO env (Maybe (Revision, BlobKey, TreeKey))
getLatestHackageRevision :: RequireHackageIndex
-> PackageName
-> Version
-> RIO env (Maybe (Revision, BlobKey, TreeKey))
getLatestHackageRevision RequireHackageIndex
req PackageName
name Version
version = do
  Map Revision BlobKey
revisions <- RequireHackageIndex
-> PackageName -> Version -> RIO env (Map Revision BlobKey)
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RequireHackageIndex
-> PackageName -> Version -> RIO env (Map Revision BlobKey)
getHackagePackageVersionRevisions RequireHackageIndex
req PackageName
name Version
version
  case (((Revision, BlobKey), Map Revision BlobKey)
 -> (Revision, BlobKey))
-> Maybe ((Revision, BlobKey), Map Revision BlobKey)
-> Maybe (Revision, BlobKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Revision, BlobKey), Map Revision BlobKey) -> (Revision, BlobKey)
forall a b. (a, b) -> a
fst (Maybe ((Revision, BlobKey), Map Revision BlobKey)
 -> Maybe (Revision, BlobKey))
-> Maybe ((Revision, BlobKey), Map Revision BlobKey)
-> Maybe (Revision, BlobKey)
forall a b. (a -> b) -> a -> b
$ Map Revision BlobKey
-> Maybe ((Revision, BlobKey), Map Revision BlobKey)
forall k a. Map k a -> Maybe ((k, a), Map k a)
Map.maxViewWithKey Map Revision BlobKey
revisions of
    Maybe (Revision, BlobKey)
Nothing -> Maybe (Revision, BlobKey, TreeKey)
-> RIO env (Maybe (Revision, BlobKey, TreeKey))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Revision, BlobKey, TreeKey)
forall a. Maybe a
Nothing
    Just (Revision
revision, cfKey :: BlobKey
cfKey@(BlobKey SHA256
sha FileSize
size)) -> do
      let cfi :: CabalFileInfo
cfi = SHA256 -> Maybe FileSize -> CabalFileInfo
CFIHash SHA256
sha (FileSize -> Maybe FileSize
forall a. a -> Maybe a
Just FileSize
size)
      TreeKey
treeKey' <- PackageIdentifierRevision -> RIO env TreeKey
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageIdentifierRevision -> RIO env TreeKey
getHackageTarballKey (PackageName
-> Version -> CabalFileInfo -> PackageIdentifierRevision
PackageIdentifierRevision PackageName
name Version
version CabalFileInfo
cfi)
      Maybe (Revision, BlobKey, TreeKey)
-> RIO env (Maybe (Revision, BlobKey, TreeKey))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Revision, BlobKey, TreeKey)
 -> RIO env (Maybe (Revision, BlobKey, TreeKey)))
-> Maybe (Revision, BlobKey, TreeKey)
-> RIO env (Maybe (Revision, BlobKey, TreeKey))
forall a b. (a -> b) -> a -> b
$ (Revision, BlobKey, TreeKey) -> Maybe (Revision, BlobKey, TreeKey)
forall a. a -> Maybe a
Just (Revision
revision, BlobKey
cfKey, TreeKey
treeKey')

-- | Fetch keys and blobs and insert into the database where possible.
fetchTreeKeys ::
     (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => [RawPackageLocationImmutable]
  -> RIO env ()
fetchTreeKeys :: [RawPackageLocationImmutable] -> RIO env ()
fetchTreeKeys [RawPackageLocationImmutable]
treeKeys = do
  () -> RIO env ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  -- Find all tree keys that are missing from the database.
  [RawPackageLocationImmutable]
packageLocationsMissing :: [RawPackageLocationImmutable] <-
    ReaderT SqlBackend (RIO env) [RawPackageLocationImmutable]
-> RIO env [RawPackageLocationImmutable]
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage
      ((RawPackageLocationImmutable -> ReaderT SqlBackend (RIO env) Bool)
-> [RawPackageLocationImmutable]
-> ReaderT SqlBackend (RIO env) [RawPackageLocationImmutable]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM
         ((Maybe (Entity Tree) -> Bool)
-> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
-> ReaderT SqlBackend (RIO env) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Entity Tree) -> Bool
forall a. Maybe a -> Bool
isNothing (ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
 -> ReaderT SqlBackend (RIO env) Bool)
-> (RawPackageLocationImmutable
    -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree)))
-> RawPackageLocationImmutable
-> ReaderT SqlBackend (RIO env) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
-> (TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree)))
-> Maybe TreeKey
-> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe (Entity Tree)
-> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Entity Tree)
forall a. Maybe a
Nothing) TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
forall env.
TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
getTreeForKey (Maybe TreeKey
 -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree)))
-> (RawPackageLocationImmutable -> Maybe TreeKey)
-> RawPackageLocationImmutable
-> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawPackageLocationImmutable -> Maybe TreeKey
getRawTreeKey)
         [RawPackageLocationImmutable]
treeKeys)
  UTCTime
pullTreeStart <- IO UTCTime -> RIO env UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  -- Pull down those tree keys from Casa, automatically inserting into
  -- our local database.
  Map TreeKey Tree
treeKeyBlobs :: Map TreeKey P.Tree <-
    (SomeException -> RIO env (Map TreeKey Tree))
-> RIO env (Map TreeKey Tree) -> RIO env (Map TreeKey Tree)
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny (RIO env (Map TreeKey Tree)
-> SomeException -> RIO env (Map TreeKey Tree)
forall a b. a -> b -> a
const RIO env (Map TreeKey Tree)
forall a. Monoid a => a
mempty)
    (([(TreeKey, Tree)] -> Map TreeKey Tree)
-> RIO env [(TreeKey, Tree)] -> RIO env (Map TreeKey Tree)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      [(TreeKey, Tree)] -> Map TreeKey Tree
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      (ReaderT SqlBackend (RIO env) [(TreeKey, Tree)]
-> RIO env [(TreeKey, Tree)]
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage
         (ConduitT
  ()
  Void
  (ResourceT (ReaderT SqlBackend (RIO env)))
  [(TreeKey, Tree)]
-> ReaderT SqlBackend (RIO env) [(TreeKey, Tree)]
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes
            ([BlobKey]
-> ConduitT
     ()
     (BlobKey, ByteString)
     (ResourceT (ReaderT SqlBackend (RIO env)))
     ()
forall (f :: * -> *) env i.
(Foldable f, HasPantryConfig env, HasLogFunc env) =>
f BlobKey
-> ConduitT
     i
     (BlobKey, ByteString)
     (ResourceT (ReaderT SqlBackend (RIO env)))
     ()
casaBlobSource
               ((TreeKey -> BlobKey) -> [TreeKey] -> [BlobKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TreeKey -> BlobKey
unTreeKey ((RawPackageLocationImmutable -> Maybe TreeKey)
-> [RawPackageLocationImmutable] -> [TreeKey]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe RawPackageLocationImmutable -> Maybe TreeKey
getRawTreeKey [RawPackageLocationImmutable]
packageLocationsMissing)) ConduitT
  ()
  (BlobKey, ByteString)
  (ResourceT (ReaderT SqlBackend (RIO env)))
  ()
-> ConduitM
     (BlobKey, ByteString)
     Void
     (ResourceT (ReaderT SqlBackend (RIO env)))
     [(TreeKey, Tree)]
-> ConduitT
     ()
     Void
     (ResourceT (ReaderT SqlBackend (RIO env)))
     [(TreeKey, Tree)]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.|
             ((BlobKey, ByteString)
 -> ResourceT (ReaderT SqlBackend (RIO env)) (TreeKey, Tree))
-> ConduitT
     (BlobKey, ByteString)
     (TreeKey, Tree)
     (ResourceT (ReaderT SqlBackend (RIO env)))
     ()
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConduitT a b m ()
mapMC (BlobKey, ByteString)
-> ResourceT (ReaderT SqlBackend (RIO env)) (TreeKey, Tree)
forall (m :: * -> *).
MonadThrow m =>
(BlobKey, ByteString) -> m (TreeKey, Tree)
parseTreeM ConduitT
  (BlobKey, ByteString)
  (TreeKey, Tree)
  (ResourceT (ReaderT SqlBackend (RIO env)))
  ()
-> ConduitM
     (TreeKey, Tree)
     Void
     (ResourceT (ReaderT SqlBackend (RIO env)))
     [(TreeKey, Tree)]
-> ConduitM
     (BlobKey, ByteString)
     Void
     (ResourceT (ReaderT SqlBackend (RIO env)))
     [(TreeKey, Tree)]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.|
             ConduitM
  (TreeKey, Tree)
  Void
  (ResourceT (ReaderT SqlBackend (RIO env)))
  [(TreeKey, Tree)]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
sinkList))))
  UTCTime
pullTreeEnd <- IO UTCTime -> RIO env UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  let pulledPackages :: [RawPackageLocationImmutable]
pulledPackages =
        (TreeKey -> Maybe RawPackageLocationImmutable)
-> [TreeKey] -> [RawPackageLocationImmutable]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
          (\TreeKey
treeKey' ->
             (RawPackageLocationImmutable -> Bool)
-> [RawPackageLocationImmutable]
-> Maybe RawPackageLocationImmutable
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find
               ((Maybe TreeKey -> Maybe TreeKey -> Bool
forall a. Eq a => a -> a -> Bool
== TreeKey -> Maybe TreeKey
forall a. a -> Maybe a
Just TreeKey
treeKey') (Maybe TreeKey -> Bool)
-> (RawPackageLocationImmutable -> Maybe TreeKey)
-> RawPackageLocationImmutable
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawPackageLocationImmutable -> Maybe TreeKey
getRawTreeKey)
               [RawPackageLocationImmutable]
packageLocationsMissing)
          (Map TreeKey Tree -> [TreeKey]
forall k a. Map k a -> [k]
Map.keys Map TreeKey Tree
treeKeyBlobs)
  -- Pull down all unique file blobs.
  let uniqueFileBlobKeys :: Set BlobKey
      uniqueFileBlobKeys :: Set BlobKey
uniqueFileBlobKeys =
        (Tree -> Set BlobKey) -> Map TreeKey Tree -> Set BlobKey
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
          (\(P.TreeMap Map SafeFilePath TreeEntry
files) -> [BlobKey] -> Set BlobKey
forall a. Ord a => [a] -> Set a
Set.fromList ((TreeEntry -> BlobKey) -> [TreeEntry] -> [BlobKey]
forall a b. (a -> b) -> [a] -> [b]
map TreeEntry -> BlobKey
teBlob (Map SafeFilePath TreeEntry -> [TreeEntry]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Map SafeFilePath TreeEntry
files)))
          Map TreeKey Tree
treeKeyBlobs
  UTCTime
pullBlobStart <- IO UTCTime -> RIO env UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  Maybe Int
mpulledBlobKeys :: Maybe Int <-
    (SomeException -> RIO env (Maybe Int))
-> RIO env (Maybe Int) -> RIO env (Maybe Int)
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny (RIO env (Maybe Int) -> SomeException -> RIO env (Maybe Int)
forall a b. a -> b -> a
const (Maybe Int -> RIO env (Maybe Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
forall a. Maybe a
Nothing))
    ((Int -> Maybe Int) -> RIO env Int -> RIO env (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Maybe Int
forall a. a -> Maybe a
Just (ReaderT SqlBackend (RIO env) Int -> RIO env Int
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage
      (ConduitT () Void (ResourceT (ReaderT SqlBackend (RIO env))) Int
-> ReaderT SqlBackend (RIO env) Int
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes
         (Set BlobKey
-> ConduitT
     ()
     (BlobKey, ByteString)
     (ResourceT (ReaderT SqlBackend (RIO env)))
     ()
forall (f :: * -> *) env i.
(Foldable f, HasPantryConfig env, HasLogFunc env) =>
f BlobKey
-> ConduitT
     i
     (BlobKey, ByteString)
     (ResourceT (ReaderT SqlBackend (RIO env)))
     ()
casaBlobSource Set BlobKey
uniqueFileBlobKeys ConduitT
  ()
  (BlobKey, ByteString)
  (ResourceT (ReaderT SqlBackend (RIO env)))
  ()
-> ConduitM
     (BlobKey, ByteString)
     Void
     (ResourceT (ReaderT SqlBackend (RIO env)))
     Int
-> ConduitT () Void (ResourceT (ReaderT SqlBackend (RIO env))) Int
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ((BlobKey, ByteString) -> Int)
-> ConduitT
     (BlobKey, ByteString)
     Int
     (ResourceT (ReaderT SqlBackend (RIO env)))
     ()
forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
mapC (Int -> (BlobKey, ByteString) -> Int
forall a b. a -> b -> a
const Int
1) ConduitT
  (BlobKey, ByteString)
  Int
  (ResourceT (ReaderT SqlBackend (RIO env)))
  ()
-> ConduitM Int Void (ResourceT (ReaderT SqlBackend (RIO env))) Int
-> ConduitM
     (BlobKey, ByteString)
     Void
     (ResourceT (ReaderT SqlBackend (RIO env)))
     Int
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM Int Void (ResourceT (ReaderT SqlBackend (RIO env))) Int
forall (m :: * -> *) a o. (Monad m, Num a) => ConduitT a o m a
sumC))))
  Maybe Int -> (Int -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Int
mpulledBlobKeys ((Int -> RIO env ()) -> RIO env ())
-> (Int -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \Int
pulledBlobKeys -> do
    UTCTime
pullBlobEnd <- IO UTCTime -> RIO env UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug
      (Utf8Builder
"Pulled from Casa: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
       [Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat (Utf8Builder -> [Utf8Builder] -> [Utf8Builder]
forall a. a -> [a] -> [a]
List.intersperse Utf8Builder
", " ((RawPackageLocationImmutable -> Utf8Builder)
-> [RawPackageLocationImmutable] -> [Utf8Builder]
forall a b. (a -> b) -> [a] -> [b]
map RawPackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display [RawPackageLocationImmutable]
pulledPackages)) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
       Utf8Builder
" (" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
       Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (FilePath -> Text
T.pack (NominalDiffTime -> FilePath
forall a. Show a => a -> FilePath
show (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
pullTreeEnd UTCTime
pullTreeStart))) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
       Utf8Builder
"), " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
       Int -> Utf8Builder -> Utf8Builder
plural Int
pulledBlobKeys Utf8Builder
"file" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
       Utf8Builder
" (" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
       Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (FilePath -> Text
T.pack (NominalDiffTime -> FilePath
forall a. Show a => a -> FilePath
show (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
pullBlobEnd UTCTime
pullBlobStart))) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
       Utf8Builder
")")
  -- Store the tree for each missing package.
  [RawPackageLocationImmutable]
-> (RawPackageLocationImmutable -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_
    [RawPackageLocationImmutable]
packageLocationsMissing
    (\RawPackageLocationImmutable
rawPackageLocationImmutable ->
       let mkey :: Maybe TreeKey
mkey = RawPackageLocationImmutable -> Maybe TreeKey
getRawTreeKey RawPackageLocationImmutable
rawPackageLocationImmutable
        in case Maybe TreeKey
mkey of
             Maybe TreeKey
Nothing ->
               Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug
                 (Utf8Builder
"Ignoring package with no tree key " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                  RawPackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
rawPackageLocationImmutable Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                  Utf8Builder
", can't look in Casa for it.")
             Just TreeKey
key ->
               case TreeKey -> Map TreeKey Tree -> Maybe Tree
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TreeKey
key Map TreeKey Tree
treeKeyBlobs of
                 Maybe Tree
Nothing ->
                   Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug
                     (Utf8Builder
"Package key " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> TreeKey -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display TreeKey
key Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" (" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                      RawPackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
rawPackageLocationImmutable Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                      Utf8Builder
") not returned from Casa.")
                 Just Tree
tree -> do
                   PackageIdentifier
identifier <-
                     RawPackageLocationImmutable -> RIO env PackageIdentifier
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env PackageIdentifier
getRawPackageLocationIdent RawPackageLocationImmutable
rawPackageLocationImmutable
                   case RawPackageLocationImmutable -> Tree -> Maybe BuildFile
forall (m :: * -> *).
MonadThrow m =>
RawPackageLocationImmutable -> Tree -> m BuildFile
findCabalOrHpackFile RawPackageLocationImmutable
rawPackageLocationImmutable Tree
tree of
                     Just BuildFile
buildFile -> 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
$ do
                       Either LoadCachedTreeException CachedTree
ecachedTree <- Tree
-> ReaderT
     SqlBackend (RIO env) (Either LoadCachedTreeException CachedTree)
forall env.
Tree
-> ReaderT
     SqlBackend (RIO env) (Either LoadCachedTreeException CachedTree)
loadCachedTree Tree
tree
                       case Either LoadCachedTreeException CachedTree
ecachedTree of
                         Left LoadCachedTreeException
e ->
                           RIO env () -> ReaderT SqlBackend (RIO env) ()
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
$ Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn
                           (Utf8Builder
"Loading cached tree after download from Casa failed on " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                            RawPackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
rawPackageLocationImmutable Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                            LoadCachedTreeException -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow LoadCachedTreeException
e)
                         Right CachedTree
cachedTree ->
                           ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
-> ReaderT SqlBackend (RIO env) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
 -> ReaderT SqlBackend (RIO env) ())
-> ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
-> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable
-> PackageIdentifier
-> CachedTree
-> BuildFile
-> ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> PackageIdentifier
-> CachedTree
-> BuildFile
-> ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
storeTree
                             RawPackageLocationImmutable
rawPackageLocationImmutable
                             PackageIdentifier
identifier
                             CachedTree
cachedTree
                             BuildFile
buildFile
                     Maybe BuildFile
Nothing ->
                       Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn
                         (Utf8Builder
"Unable to find build file for package: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                          RawPackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
rawPackageLocationImmutable))
  where
    unTreeKey :: TreeKey -> BlobKey
    unTreeKey :: TreeKey -> BlobKey
unTreeKey (P.TreeKey BlobKey
blobKey) = BlobKey
blobKey

-- | Download all of the packages provided into the local cache
-- without performing any unpacking. Can be useful for build tools
-- wanting to prefetch or provide an offline mode.
--
-- @since 0.1.0.0
fetchPackages
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env, Foldable f)
  => f PackageLocationImmutable
  -> RIO env ()
fetchPackages :: f PackageLocationImmutable -> RIO env ()
fetchPackages f PackageLocationImmutable
pls = do
    [RawPackageLocationImmutable] -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
[RawPackageLocationImmutable] -> RIO env ()
fetchTreeKeys ((PackageLocationImmutable -> RawPackageLocationImmutable)
-> [PackageLocationImmutable] -> [RawPackageLocationImmutable]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI (f PackageLocationImmutable -> [PackageLocationImmutable]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f PackageLocationImmutable
pls))
    ((PackageIdentifierRevision, Maybe TreeKey) -> RIO env ())
-> [(PackageIdentifierRevision, Maybe TreeKey)] -> RIO env ()
forall (f :: * -> *) env a.
(Foldable f, HasPantryConfig env) =>
(a -> RIO env ()) -> f a -> RIO env ()
traverseConcurrently_ (RIO env HackageTarballResult -> RIO env ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RIO env HackageTarballResult -> RIO env ())
-> ((PackageIdentifierRevision, Maybe TreeKey)
    -> RIO env HackageTarballResult)
-> (PackageIdentifierRevision, Maybe TreeKey)
-> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageIdentifierRevision
 -> Maybe TreeKey -> RIO env HackageTarballResult)
-> (PackageIdentifierRevision, Maybe TreeKey)
-> RIO env HackageTarballResult
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PackageIdentifierRevision
-> Maybe TreeKey -> RIO env HackageTarballResult
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageIdentifierRevision
-> Maybe TreeKey -> RIO env HackageTarballResult
getHackageTarball) [(PackageIdentifierRevision, Maybe TreeKey)]
hackages
    -- TODO in the future, be concurrent in these as well
    [(Archive, PackageMetadata)] -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
[(Archive, PackageMetadata)] -> RIO env ()
fetchArchives [(Archive, PackageMetadata)]
archives
    [(Repo, PackageMetadata)] -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
[(Repo, PackageMetadata)] -> RIO env ()
fetchRepos [(Repo, PackageMetadata)]
repos
  where
    s :: a -> Endo [a]
s a
x = ([a] -> [a]) -> Endo [a]
forall a. (a -> a) -> Endo a
Endo (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:)
    run :: Endo [a] -> [a]
run (Endo [a] -> [a]
f) = [a] -> [a]
f []
    (Endo [(PackageIdentifierRevision, Maybe TreeKey)]
hackagesE, Endo [(Archive, PackageMetadata)]
archivesE, Endo [(Repo, PackageMetadata)]
reposE) = (PackageLocationImmutable
 -> (Endo [(PackageIdentifierRevision, Maybe TreeKey)],
     Endo [(Archive, PackageMetadata)], Endo [(Repo, PackageMetadata)]))
-> f PackageLocationImmutable
-> (Endo [(PackageIdentifierRevision, Maybe TreeKey)],
    Endo [(Archive, PackageMetadata)], Endo [(Repo, PackageMetadata)])
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap PackageLocationImmutable
-> (Endo [(PackageIdentifierRevision, Maybe TreeKey)],
    Endo [(Archive, PackageMetadata)], Endo [(Repo, PackageMetadata)])
go f PackageLocationImmutable
pls
    hackages :: [(PackageIdentifierRevision, Maybe TreeKey)]
hackages = Endo [(PackageIdentifierRevision, Maybe TreeKey)]
-> [(PackageIdentifierRevision, Maybe TreeKey)]
forall a. Endo [a] -> [a]
run Endo [(PackageIdentifierRevision, Maybe TreeKey)]
hackagesE
    archives :: [(Archive, PackageMetadata)]
archives = Endo [(Archive, PackageMetadata)] -> [(Archive, PackageMetadata)]
forall a. Endo [a] -> [a]
run Endo [(Archive, PackageMetadata)]
archivesE
    repos :: [(Repo, PackageMetadata)]
repos = Endo [(Repo, PackageMetadata)] -> [(Repo, PackageMetadata)]
forall a. Endo [a] -> [a]
run Endo [(Repo, PackageMetadata)]
reposE

    go :: PackageLocationImmutable
-> (Endo [(PackageIdentifierRevision, Maybe TreeKey)],
    Endo [(Archive, PackageMetadata)], Endo [(Repo, PackageMetadata)])
go (PLIHackage PackageIdentifier
ident BlobKey
cfHash TreeKey
tree) = ((PackageIdentifierRevision, Maybe TreeKey)
-> Endo [(PackageIdentifierRevision, Maybe TreeKey)]
forall a. a -> Endo [a]
s (PackageIdentifier -> BlobKey -> PackageIdentifierRevision
toPir PackageIdentifier
ident BlobKey
cfHash, TreeKey -> Maybe TreeKey
forall a. a -> Maybe a
Just TreeKey
tree), Endo [(Archive, PackageMetadata)]
forall a. Monoid a => a
mempty, Endo [(Repo, PackageMetadata)]
forall a. Monoid a => a
mempty)
    go (PLIArchive Archive
archive PackageMetadata
pm) = (Endo [(PackageIdentifierRevision, Maybe TreeKey)]
forall a. Monoid a => a
mempty, (Archive, PackageMetadata) -> Endo [(Archive, PackageMetadata)]
forall a. a -> Endo [a]
s (Archive
archive, PackageMetadata
pm), Endo [(Repo, PackageMetadata)]
forall a. Monoid a => a
mempty)
    go (PLIRepo Repo
repo PackageMetadata
pm) = (Endo [(PackageIdentifierRevision, Maybe TreeKey)]
forall a. Monoid a => a
mempty, Endo [(Archive, PackageMetadata)]
forall a. Monoid a => a
mempty, (Repo, PackageMetadata) -> Endo [(Repo, PackageMetadata)]
forall a. a -> Endo [a]
s (Repo
repo, PackageMetadata
pm))

    toPir :: PackageIdentifier -> BlobKey -> PackageIdentifierRevision
toPir (PackageIdentifier PackageName
name Version
ver) (BlobKey SHA256
sha FileSize
size) =
      PackageName
-> Version -> CabalFileInfo -> PackageIdentifierRevision
PackageIdentifierRevision PackageName
name Version
ver (SHA256 -> Maybe FileSize -> CabalFileInfo
CFIHash SHA256
sha (FileSize -> Maybe FileSize
forall a. a -> Maybe a
Just FileSize
size))

-- | Unpack a given 'RawPackageLocationImmutable' into the given
-- directory. Does not generate any extra subdirectories.
--
-- @since 0.1.0.0
unpackPackageLocationRaw
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => Path Abs Dir -- ^ unpack directory
  -> RawPackageLocationImmutable
  -> RIO env ()
unpackPackageLocationRaw :: Path Abs Dir -> RawPackageLocationImmutable -> RIO env ()
unpackPackageLocationRaw Path Abs Dir
fp RawPackageLocationImmutable
loc = RawPackageLocationImmutable -> RIO env Package
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env Package
loadPackageRaw RawPackageLocationImmutable
loc RIO env Package -> (Package -> RIO env ()) -> RIO env ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RawPackageLocationImmutable -> Path Abs Dir -> Tree -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawPackageLocationImmutable -> Path Abs Dir -> Tree -> RIO env ()
unpackTree RawPackageLocationImmutable
loc Path Abs Dir
fp (Tree -> RIO env ()) -> (Package -> Tree) -> Package -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Package -> Tree
packageTree

-- | Unpack a given 'PackageLocationImmutable' into the given
-- directory. Does not generate any extra subdirectories.
--
-- @since 0.1.0.0
unpackPackageLocation
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => Path Abs Dir -- ^ unpack directory
  -> PackageLocationImmutable
  -> RIO env ()
unpackPackageLocation :: Path Abs Dir -> PackageLocationImmutable -> RIO env ()
unpackPackageLocation Path Abs Dir
fp PackageLocationImmutable
loc = PackageLocationImmutable -> RIO env Package
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageLocationImmutable -> RIO env Package
loadPackage PackageLocationImmutable
loc RIO env Package -> (Package -> RIO env ()) -> RIO env ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RawPackageLocationImmutable -> Path Abs Dir -> Tree -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawPackageLocationImmutable -> Path Abs Dir -> Tree -> RIO env ()
unpackTree (PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI PackageLocationImmutable
loc) Path Abs Dir
fp (Tree -> RIO env ()) -> (Package -> Tree) -> Package -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Package -> Tree
packageTree

-- | Load the cabal file for the given 'PackageLocationImmutable'.
--
-- This function ignores all warnings.
--
-- @since 0.1.0.0
loadCabalFileImmutable
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => PackageLocationImmutable
  -> RIO env GenericPackageDescription
loadCabalFileImmutable :: PackageLocationImmutable -> RIO env GenericPackageDescription
loadCabalFileImmutable PackageLocationImmutable
loc = RIO env GenericPackageDescription
-> RIO env GenericPackageDescription
forall (m :: * -> *) s.
(MonadReader s m, HasPantryConfig s, MonadIO m) =>
m GenericPackageDescription -> m GenericPackageDescription
withCache (RIO env GenericPackageDescription
 -> RIO env GenericPackageDescription)
-> RIO env GenericPackageDescription
-> RIO env GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ do
  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Parsing cabal file for " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> PackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display PackageLocationImmutable
loc
  ByteString
bs <- PackageLocationImmutable -> RIO env ByteString
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageLocationImmutable -> RIO env ByteString
loadCabalFileBytes PackageLocationImmutable
loc
  ([PWarning]
_warnings, GenericPackageDescription
gpd) <- Either RawPackageLocationImmutable (Path Abs File)
-> ByteString -> RIO env ([PWarning], GenericPackageDescription)
forall (m :: * -> *).
MonadThrow m =>
Either RawPackageLocationImmutable (Path Abs File)
-> ByteString -> m ([PWarning], GenericPackageDescription)
rawParseGPD (RawPackageLocationImmutable
-> Either RawPackageLocationImmutable (Path Abs File)
forall a b. a -> Either a b
Left (RawPackageLocationImmutable
 -> Either RawPackageLocationImmutable (Path Abs File))
-> RawPackageLocationImmutable
-> Either RawPackageLocationImmutable (Path Abs File)
forall a b. (a -> b) -> a -> b
$ PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI PackageLocationImmutable
loc) ByteString
bs
  let pm :: PackageMetadata
pm =
        case PackageLocationImmutable
loc of
          PLIHackage (PackageIdentifier PackageName
name Version
version) BlobKey
_cfHash TreeKey
mtree -> PackageMetadata :: PackageIdentifier -> TreeKey -> PackageMetadata
PackageMetadata
            { pmIdent :: PackageIdentifier
pmIdent = PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version
            , pmTreeKey :: TreeKey
pmTreeKey = TreeKey
mtree
            }
          PLIArchive Archive
_ PackageMetadata
pm' -> PackageMetadata
pm'
          PLIRepo Repo
_ PackageMetadata
pm' -> PackageMetadata
pm'
  let exc :: PantryException
exc = RawPackageLocationImmutable
-> RawPackageMetadata
-> Maybe TreeKey
-> PackageIdentifier
-> PantryException
MismatchedPackageMetadata (PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI PackageLocationImmutable
loc) (PackageMetadata -> RawPackageMetadata
toRawPM PackageMetadata
pm) Maybe TreeKey
forall a. Maybe a
Nothing
        (GenericPackageDescription -> PackageIdentifier
gpdPackageIdentifier GenericPackageDescription
gpd)
      PackageIdentifier PackageName
name Version
ver = PackageMetadata -> PackageIdentifier
pmIdent PackageMetadata
pm
  RIO env GenericPackageDescription
-> (GenericPackageDescription -> RIO env GenericPackageDescription)
-> Maybe GenericPackageDescription
-> RIO env GenericPackageDescription
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PantryException -> RIO env GenericPackageDescription
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO PantryException
exc) GenericPackageDescription -> RIO env GenericPackageDescription
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe GenericPackageDescription
 -> RIO env GenericPackageDescription)
-> Maybe GenericPackageDescription
-> RIO env GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ do
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ PackageName
name PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== GenericPackageDescription -> PackageName
gpdPackageName GenericPackageDescription
gpd
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Version
ver Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== GenericPackageDescription -> Version
gpdVersion GenericPackageDescription
gpd
    GenericPackageDescription -> Maybe GenericPackageDescription
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenericPackageDescription
gpd
  where
    withCache :: m GenericPackageDescription -> m GenericPackageDescription
withCache m GenericPackageDescription
inner = do
      let rawLoc :: RawPackageLocationImmutable
rawLoc = PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI PackageLocationImmutable
loc
      IORef (Map RawPackageLocationImmutable GenericPackageDescription)
ref <- Getting
  (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
  s
  (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
-> m (IORef
        (Map RawPackageLocationImmutable GenericPackageDescription))
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting
   (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
   s
   (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
 -> m (IORef
         (Map RawPackageLocationImmutable GenericPackageDescription)))
-> Getting
     (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
     s
     (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
-> m (IORef
        (Map RawPackageLocationImmutable GenericPackageDescription))
forall a b. (a -> b) -> a -> b
$ (PantryConfig
 -> Const
      (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
      PantryConfig)
-> s
-> Const
     (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
     s
forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigL((PantryConfig
  -> Const
       (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
       PantryConfig)
 -> s
 -> Const
      (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
      s)
-> ((IORef
       (Map RawPackageLocationImmutable GenericPackageDescription)
     -> Const
          (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
          (IORef
             (Map RawPackageLocationImmutable GenericPackageDescription)))
    -> PantryConfig
    -> Const
         (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
         PantryConfig)
-> Getting
     (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
     s
     (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PantryConfig
 -> IORef
      (Map RawPackageLocationImmutable GenericPackageDescription))
-> SimpleGetter
     PantryConfig
     (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig
-> IORef
     (Map RawPackageLocationImmutable GenericPackageDescription)
pcParsedCabalFilesRawImmutable
      Map RawPackageLocationImmutable GenericPackageDescription
m0 <- IORef (Map RawPackageLocationImmutable GenericPackageDescription)
-> m (Map RawPackageLocationImmutable GenericPackageDescription)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Map RawPackageLocationImmutable GenericPackageDescription)
ref
      case RawPackageLocationImmutable
-> Map RawPackageLocationImmutable GenericPackageDescription
-> Maybe GenericPackageDescription
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RawPackageLocationImmutable
rawLoc Map RawPackageLocationImmutable GenericPackageDescription
m0 of
        Just GenericPackageDescription
x -> GenericPackageDescription -> m GenericPackageDescription
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenericPackageDescription
x
        Maybe GenericPackageDescription
Nothing -> do
          GenericPackageDescription
x <- m GenericPackageDescription
inner
          IORef (Map RawPackageLocationImmutable GenericPackageDescription)
-> (Map RawPackageLocationImmutable GenericPackageDescription
    -> (Map RawPackageLocationImmutable GenericPackageDescription,
        GenericPackageDescription))
-> m GenericPackageDescription
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef (Map RawPackageLocationImmutable GenericPackageDescription)
ref ((Map RawPackageLocationImmutable GenericPackageDescription
  -> (Map RawPackageLocationImmutable GenericPackageDescription,
      GenericPackageDescription))
 -> m GenericPackageDescription)
-> (Map RawPackageLocationImmutable GenericPackageDescription
    -> (Map RawPackageLocationImmutable GenericPackageDescription,
        GenericPackageDescription))
-> m GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ \Map RawPackageLocationImmutable GenericPackageDescription
m -> (RawPackageLocationImmutable
-> GenericPackageDescription
-> Map RawPackageLocationImmutable GenericPackageDescription
-> Map RawPackageLocationImmutable GenericPackageDescription
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert RawPackageLocationImmutable
rawLoc GenericPackageDescription
x Map RawPackageLocationImmutable GenericPackageDescription
m, GenericPackageDescription
x)

-- | Load the cabal file for the given 'RawPackageLocationImmutable'.
--
-- This function ignores all warnings.
--
-- Note that, for now, this will not allow support for hpack files in
-- these package locations. Instead, all @PackageLocationImmutable@s
-- will require a .cabal file. This may be relaxed in the future.
--
-- @since 0.1.0.0
loadCabalFileRawImmutable
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => RawPackageLocationImmutable
  -> RIO env GenericPackageDescription
loadCabalFileRawImmutable :: RawPackageLocationImmutable -> RIO env GenericPackageDescription
loadCabalFileRawImmutable RawPackageLocationImmutable
loc = RIO env GenericPackageDescription
-> RIO env GenericPackageDescription
forall (m :: * -> *) s.
(MonadReader s m, HasPantryConfig s, MonadIO m) =>
m GenericPackageDescription -> m GenericPackageDescription
withCache (RIO env GenericPackageDescription
 -> RIO env GenericPackageDescription)
-> RIO env GenericPackageDescription
-> RIO env GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ do
  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Parsing cabal file for " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> RawPackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
loc
  ByteString
bs <- RawPackageLocationImmutable -> RIO env ByteString
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env ByteString
loadRawCabalFileBytes RawPackageLocationImmutable
loc
  ([PWarning]
_warnings, GenericPackageDescription
gpd) <- Either RawPackageLocationImmutable (Path Abs File)
-> ByteString -> RIO env ([PWarning], GenericPackageDescription)
forall (m :: * -> *).
MonadThrow m =>
Either RawPackageLocationImmutable (Path Abs File)
-> ByteString -> m ([PWarning], GenericPackageDescription)
rawParseGPD (RawPackageLocationImmutable
-> Either RawPackageLocationImmutable (Path Abs File)
forall a b. a -> Either a b
Left RawPackageLocationImmutable
loc) ByteString
bs
  let rpm :: RawPackageMetadata
rpm =
        case RawPackageLocationImmutable
loc of
          RPLIHackage (PackageIdentifierRevision PackageName
name Version
version CabalFileInfo
_cfi) Maybe TreeKey
mtree -> RawPackageMetadata :: Maybe PackageName
-> Maybe Version -> Maybe TreeKey -> RawPackageMetadata
RawPackageMetadata
            { rpmName :: Maybe PackageName
rpmName = PackageName -> Maybe PackageName
forall a. a -> Maybe a
Just PackageName
name
            , rpmVersion :: Maybe Version
rpmVersion = Version -> Maybe Version
forall a. a -> Maybe a
Just Version
version
            , rpmTreeKey :: Maybe TreeKey
rpmTreeKey = Maybe TreeKey
mtree
            }
          RPLIArchive RawArchive
_ RawPackageMetadata
rpm' -> RawPackageMetadata
rpm'
          RPLIRepo Repo
_ RawPackageMetadata
rpm' -> RawPackageMetadata
rpm'
  let exc :: PantryException
exc = RawPackageLocationImmutable
-> RawPackageMetadata
-> Maybe TreeKey
-> PackageIdentifier
-> PantryException
MismatchedPackageMetadata RawPackageLocationImmutable
loc RawPackageMetadata
rpm Maybe TreeKey
forall a. Maybe a
Nothing (GenericPackageDescription -> PackageIdentifier
gpdPackageIdentifier GenericPackageDescription
gpd)
  RIO env GenericPackageDescription
-> (GenericPackageDescription -> RIO env GenericPackageDescription)
-> Maybe GenericPackageDescription
-> RIO env GenericPackageDescription
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PantryException -> RIO env GenericPackageDescription
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO PantryException
exc) GenericPackageDescription -> RIO env GenericPackageDescription
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe GenericPackageDescription
 -> RIO env GenericPackageDescription)
-> Maybe GenericPackageDescription
-> RIO env GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ do
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> (PackageName -> Bool) -> Maybe PackageName -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== GenericPackageDescription -> PackageName
gpdPackageName GenericPackageDescription
gpd) (RawPackageMetadata -> Maybe PackageName
rpmName RawPackageMetadata
rpm)
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> (Version -> Bool) -> Maybe Version -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== GenericPackageDescription -> Version
gpdVersion GenericPackageDescription
gpd) (RawPackageMetadata -> Maybe Version
rpmVersion RawPackageMetadata
rpm)
    GenericPackageDescription -> Maybe GenericPackageDescription
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenericPackageDescription
gpd
  where
    withCache :: m GenericPackageDescription -> m GenericPackageDescription
withCache m GenericPackageDescription
inner = do
      IORef (Map RawPackageLocationImmutable GenericPackageDescription)
ref <- Getting
  (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
  s
  (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
-> m (IORef
        (Map RawPackageLocationImmutable GenericPackageDescription))
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting
   (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
   s
   (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
 -> m (IORef
         (Map RawPackageLocationImmutable GenericPackageDescription)))
-> Getting
     (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
     s
     (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
-> m (IORef
        (Map RawPackageLocationImmutable GenericPackageDescription))
forall a b. (a -> b) -> a -> b
$ (PantryConfig
 -> Const
      (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
      PantryConfig)
-> s
-> Const
     (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
     s
forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigL((PantryConfig
  -> Const
       (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
       PantryConfig)
 -> s
 -> Const
      (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
      s)
-> ((IORef
       (Map RawPackageLocationImmutable GenericPackageDescription)
     -> Const
          (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
          (IORef
             (Map RawPackageLocationImmutable GenericPackageDescription)))
    -> PantryConfig
    -> Const
         (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
         PantryConfig)
-> Getting
     (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
     s
     (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PantryConfig
 -> IORef
      (Map RawPackageLocationImmutable GenericPackageDescription))
-> SimpleGetter
     PantryConfig
     (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig
-> IORef
     (Map RawPackageLocationImmutable GenericPackageDescription)
pcParsedCabalFilesRawImmutable
      Map RawPackageLocationImmutable GenericPackageDescription
m0 <- IORef (Map RawPackageLocationImmutable GenericPackageDescription)
-> m (Map RawPackageLocationImmutable GenericPackageDescription)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Map RawPackageLocationImmutable GenericPackageDescription)
ref
      case RawPackageLocationImmutable
-> Map RawPackageLocationImmutable GenericPackageDescription
-> Maybe GenericPackageDescription
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RawPackageLocationImmutable
loc Map RawPackageLocationImmutable GenericPackageDescription
m0 of
        Just GenericPackageDescription
x -> GenericPackageDescription -> m GenericPackageDescription
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenericPackageDescription
x
        Maybe GenericPackageDescription
Nothing -> do
          GenericPackageDescription
x <- m GenericPackageDescription
inner
          IORef (Map RawPackageLocationImmutable GenericPackageDescription)
-> (Map RawPackageLocationImmutable GenericPackageDescription
    -> (Map RawPackageLocationImmutable GenericPackageDescription,
        GenericPackageDescription))
-> m GenericPackageDescription
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef (Map RawPackageLocationImmutable GenericPackageDescription)
ref ((Map RawPackageLocationImmutable GenericPackageDescription
  -> (Map RawPackageLocationImmutable GenericPackageDescription,
      GenericPackageDescription))
 -> m GenericPackageDescription)
-> (Map RawPackageLocationImmutable GenericPackageDescription
    -> (Map RawPackageLocationImmutable GenericPackageDescription,
        GenericPackageDescription))
-> m GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ \Map RawPackageLocationImmutable GenericPackageDescription
m -> (RawPackageLocationImmutable
-> GenericPackageDescription
-> Map RawPackageLocationImmutable GenericPackageDescription
-> Map RawPackageLocationImmutable GenericPackageDescription
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert RawPackageLocationImmutable
loc GenericPackageDescription
x Map RawPackageLocationImmutable GenericPackageDescription
m, GenericPackageDescription
x)

-- | Same as 'loadCabalFileRawImmutable', but takes a
-- 'RawPackageLocation'. Never prints warnings, see 'loadCabalFilePath'
-- for that.
--
-- @since 0.1.0.0
loadCabalFileRaw
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => RawPackageLocation
  -> RIO env GenericPackageDescription
loadCabalFileRaw :: RawPackageLocation -> RIO env GenericPackageDescription
loadCabalFileRaw (RPLImmutable RawPackageLocationImmutable
loc) = RawPackageLocationImmutable -> RIO env GenericPackageDescription
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env GenericPackageDescription
loadCabalFileRawImmutable RawPackageLocationImmutable
loc
loadCabalFileRaw (RPLMutable ResolvedPath Dir
rfp) = do
  (PrintWarnings -> IO GenericPackageDescription
gpdio, PackageName
_, Path Abs File
_) <- Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
loadCabalFilePath (ResolvedPath Dir -> Path Abs Dir
forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath Dir
rfp)
  IO GenericPackageDescription -> RIO env GenericPackageDescription
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GenericPackageDescription -> RIO env GenericPackageDescription)
-> IO GenericPackageDescription
-> RIO env GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ PrintWarnings -> IO GenericPackageDescription
gpdio PrintWarnings
NoPrintWarnings

-- | Same as 'loadCabalFileImmutable', but takes a
-- 'PackageLocation'. Never prints warnings, see 'loadCabalFilePath'
-- for that.
--
-- @since 0.1.0.0
loadCabalFile
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => PackageLocation
  -> RIO env GenericPackageDescription
loadCabalFile :: PackageLocation -> RIO env GenericPackageDescription
loadCabalFile (PLImmutable PackageLocationImmutable
loc) = PackageLocationImmutable -> RIO env GenericPackageDescription
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageLocationImmutable -> RIO env GenericPackageDescription
loadCabalFileImmutable PackageLocationImmutable
loc
loadCabalFile (PLMutable ResolvedPath Dir
rfp) = do
  (PrintWarnings -> IO GenericPackageDescription
gpdio, PackageName
_, Path Abs File
_) <- Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
loadCabalFilePath (ResolvedPath Dir -> Path Abs Dir
forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath Dir
rfp)
  IO GenericPackageDescription -> RIO env GenericPackageDescription
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GenericPackageDescription -> RIO env GenericPackageDescription)
-> IO GenericPackageDescription
-> RIO env GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ PrintWarnings -> IO GenericPackageDescription
gpdio PrintWarnings
NoPrintWarnings

-- | Parse the cabal file for the package inside the given
-- directory. Performs various sanity checks, such as the file name
-- being correct and having only a single cabal file.
--
-- @since 0.1.0.0
loadCabalFilePath
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => Path Abs Dir -- ^ project directory, with a cabal file or hpack file
  -> RIO env
       ( PrintWarnings -> IO GenericPackageDescription
       , PackageName
       , Path Abs File
       )
loadCabalFilePath :: Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
loadCabalFilePath Path Abs Dir
dir = do
  IORef
  (Map
     (Path Abs Dir)
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File))
ref <- Getting
  (IORef
     (Map
        (Path Abs Dir)
        (PrintWarnings -> IO GenericPackageDescription, PackageName,
         Path Abs File)))
  env
  (IORef
     (Map
        (Path Abs Dir)
        (PrintWarnings -> IO GenericPackageDescription, PackageName,
         Path Abs File)))
-> RIO
     env
     (IORef
        (Map
           (Path Abs Dir)
           (PrintWarnings -> IO GenericPackageDescription, PackageName,
            Path Abs File)))
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting
   (IORef
      (Map
         (Path Abs Dir)
         (PrintWarnings -> IO GenericPackageDescription, PackageName,
          Path Abs File)))
   env
   (IORef
      (Map
         (Path Abs Dir)
         (PrintWarnings -> IO GenericPackageDescription, PackageName,
          Path Abs File)))
 -> RIO
      env
      (IORef
         (Map
            (Path Abs Dir)
            (PrintWarnings -> IO GenericPackageDescription, PackageName,
             Path Abs File))))
-> Getting
     (IORef
        (Map
           (Path Abs Dir)
           (PrintWarnings -> IO GenericPackageDescription, PackageName,
            Path Abs File)))
     env
     (IORef
        (Map
           (Path Abs Dir)
           (PrintWarnings -> IO GenericPackageDescription, PackageName,
            Path Abs File)))
-> RIO
     env
     (IORef
        (Map
           (Path Abs Dir)
           (PrintWarnings -> IO GenericPackageDescription, PackageName,
            Path Abs File)))
forall a b. (a -> b) -> a -> b
$ (PantryConfig
 -> Const
      (IORef
         (Map
            (Path Abs Dir)
            (PrintWarnings -> IO GenericPackageDescription, PackageName,
             Path Abs File)))
      PantryConfig)
-> env
-> Const
     (IORef
        (Map
           (Path Abs Dir)
           (PrintWarnings -> IO GenericPackageDescription, PackageName,
            Path Abs File)))
     env
forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigL((PantryConfig
  -> Const
       (IORef
          (Map
             (Path Abs Dir)
             (PrintWarnings -> IO GenericPackageDescription, PackageName,
              Path Abs File)))
       PantryConfig)
 -> env
 -> Const
      (IORef
         (Map
            (Path Abs Dir)
            (PrintWarnings -> IO GenericPackageDescription, PackageName,
             Path Abs File)))
      env)
-> ((IORef
       (Map
          (Path Abs Dir)
          (PrintWarnings -> IO GenericPackageDescription, PackageName,
           Path Abs File))
     -> Const
          (IORef
             (Map
                (Path Abs Dir)
                (PrintWarnings -> IO GenericPackageDescription, PackageName,
                 Path Abs File)))
          (IORef
             (Map
                (Path Abs Dir)
                (PrintWarnings -> IO GenericPackageDescription, PackageName,
                 Path Abs File))))
    -> PantryConfig
    -> Const
         (IORef
            (Map
               (Path Abs Dir)
               (PrintWarnings -> IO GenericPackageDescription, PackageName,
                Path Abs File)))
         PantryConfig)
-> Getting
     (IORef
        (Map
           (Path Abs Dir)
           (PrintWarnings -> IO GenericPackageDescription, PackageName,
            Path Abs File)))
     env
     (IORef
        (Map
           (Path Abs Dir)
           (PrintWarnings -> IO GenericPackageDescription, PackageName,
            Path Abs File)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PantryConfig
 -> IORef
      (Map
         (Path Abs Dir)
         (PrintWarnings -> IO GenericPackageDescription, PackageName,
          Path Abs File)))
-> SimpleGetter
     PantryConfig
     (IORef
        (Map
           (Path Abs Dir)
           (PrintWarnings -> IO GenericPackageDescription, PackageName,
            Path Abs File)))
forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig
-> IORef
     (Map
        (Path Abs Dir)
        (PrintWarnings -> IO GenericPackageDescription, PackageName,
         Path Abs File))
pcParsedCabalFilesMutable
  Maybe
  (PrintWarnings -> IO GenericPackageDescription, PackageName,
   Path Abs File)
mcached <- Path Abs Dir
-> Map
     (Path Abs Dir)
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
-> Maybe
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Path Abs Dir
dir (Map
   (Path Abs Dir)
   (PrintWarnings -> IO GenericPackageDescription, PackageName,
    Path Abs File)
 -> Maybe
      (PrintWarnings -> IO GenericPackageDescription, PackageName,
       Path Abs File))
-> RIO
     env
     (Map
        (Path Abs Dir)
        (PrintWarnings -> IO GenericPackageDescription, PackageName,
         Path Abs File))
-> RIO
     env
     (Maybe
        (PrintWarnings -> IO GenericPackageDescription, PackageName,
         Path Abs File))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef
  (Map
     (Path Abs Dir)
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File))
-> RIO
     env
     (Map
        (Path Abs Dir)
        (PrintWarnings -> IO GenericPackageDescription, PackageName,
         Path Abs File))
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef
  (Map
     (Path Abs Dir)
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File))
ref
  case Maybe
  (PrintWarnings -> IO GenericPackageDescription, PackageName,
   Path Abs File)
mcached of
    Just (PrintWarnings -> IO GenericPackageDescription, PackageName,
 Path Abs File)
triple -> (PrintWarnings -> IO GenericPackageDescription, PackageName,
 Path Abs File)
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PrintWarnings -> IO GenericPackageDescription, PackageName,
 Path Abs File)
triple
    Maybe
  (PrintWarnings -> IO GenericPackageDescription, PackageName,
   Path Abs File)
Nothing -> do
      (PackageName
name, Path Abs File
cabalfp) <- 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
dir
      IORef (Maybe ([PWarning], GenericPackageDescription))
gpdRef <- Maybe ([PWarning], GenericPackageDescription)
-> RIO env (IORef (Maybe ([PWarning], GenericPackageDescription)))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Maybe ([PWarning], GenericPackageDescription)
forall a. Maybe a
Nothing
      RIO env GenericPackageDescription -> IO GenericPackageDescription
run <- RIO
  env
  (RIO env GenericPackageDescription -> IO GenericPackageDescription)
forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
      let gpdio :: PrintWarnings -> IO GenericPackageDescription
gpdio = RIO env GenericPackageDescription -> IO GenericPackageDescription
run (RIO env GenericPackageDescription -> IO GenericPackageDescription)
-> (PrintWarnings -> RIO env GenericPackageDescription)
-> PrintWarnings
-> IO GenericPackageDescription
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File
-> IORef (Maybe ([PWarning], GenericPackageDescription))
-> PrintWarnings
-> RIO env GenericPackageDescription
forall (m :: * -> *) env.
(MonadIO m, MonadThrow m, MonadReader env m, HasLogFunc env) =>
Path Abs File
-> IORef (Maybe ([PWarning], GenericPackageDescription))
-> PrintWarnings
-> m GenericPackageDescription
getGPD Path Abs File
cabalfp IORef (Maybe ([PWarning], GenericPackageDescription))
gpdRef
          triple :: (PrintWarnings -> IO GenericPackageDescription, PackageName,
 Path Abs File)
triple = (PrintWarnings -> IO GenericPackageDescription
gpdio, PackageName
name, Path Abs File
cabalfp)
      IORef
  (Map
     (Path Abs Dir)
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File))
-> (Map
      (Path Abs Dir)
      (PrintWarnings -> IO GenericPackageDescription, PackageName,
       Path Abs File)
    -> (Map
          (Path Abs Dir)
          (PrintWarnings -> IO GenericPackageDescription, PackageName,
           Path Abs File),
        (PrintWarnings -> IO GenericPackageDescription, PackageName,
         Path Abs File)))
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef
  (Map
     (Path Abs Dir)
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File))
ref ((Map
    (Path Abs Dir)
    (PrintWarnings -> IO GenericPackageDescription, PackageName,
     Path Abs File)
  -> (Map
        (Path Abs Dir)
        (PrintWarnings -> IO GenericPackageDescription, PackageName,
         Path Abs File),
      (PrintWarnings -> IO GenericPackageDescription, PackageName,
       Path Abs File)))
 -> RIO
      env
      (PrintWarnings -> IO GenericPackageDescription, PackageName,
       Path Abs File))
-> (Map
      (Path Abs Dir)
      (PrintWarnings -> IO GenericPackageDescription, PackageName,
       Path Abs File)
    -> (Map
          (Path Abs Dir)
          (PrintWarnings -> IO GenericPackageDescription, PackageName,
           Path Abs File),
        (PrintWarnings -> IO GenericPackageDescription, PackageName,
         Path Abs File)))
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
forall a b. (a -> b) -> a -> b
$ \Map
  (Path Abs Dir)
  (PrintWarnings -> IO GenericPackageDescription, PackageName,
   Path Abs File)
m -> (Path Abs Dir
-> (PrintWarnings -> IO GenericPackageDescription, PackageName,
    Path Abs File)
-> Map
     (Path Abs Dir)
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
-> Map
     (Path Abs Dir)
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Path Abs Dir
dir (PrintWarnings -> IO GenericPackageDescription, PackageName,
 Path Abs File)
triple Map
  (Path Abs Dir)
  (PrintWarnings -> IO GenericPackageDescription, PackageName,
   Path Abs File)
m, (PrintWarnings -> IO GenericPackageDescription, PackageName,
 Path Abs File)
triple)
  where
    getGPD :: Path Abs File
-> IORef (Maybe ([PWarning], GenericPackageDescription))
-> PrintWarnings
-> m GenericPackageDescription
getGPD Path Abs File
cabalfp IORef (Maybe ([PWarning], GenericPackageDescription))
gpdRef PrintWarnings
printWarnings = do
      Maybe ([PWarning], GenericPackageDescription)
mpair <- IORef (Maybe ([PWarning], GenericPackageDescription))
-> m (Maybe ([PWarning], GenericPackageDescription))
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Maybe ([PWarning], GenericPackageDescription))
gpdRef
      ([PWarning]
warnings0, GenericPackageDescription
gpd) <-
        case Maybe ([PWarning], GenericPackageDescription)
mpair of
          Just ([PWarning], GenericPackageDescription)
pair -> ([PWarning], GenericPackageDescription)
-> m ([PWarning], GenericPackageDescription)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([PWarning], GenericPackageDescription)
pair
          Maybe ([PWarning], GenericPackageDescription)
Nothing -> do
            ByteString
bs <- IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
forall (m :: * -> *). MonadIO m => FilePath -> m ByteString
B.readFile (FilePath -> IO ByteString) -> FilePath -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
cabalfp
            ([PWarning]
warnings0, GenericPackageDescription
gpd) <- Either RawPackageLocationImmutable (Path Abs File)
-> ByteString -> m ([PWarning], GenericPackageDescription)
forall (m :: * -> *).
MonadThrow m =>
Either RawPackageLocationImmutable (Path Abs File)
-> ByteString -> m ([PWarning], GenericPackageDescription)
rawParseGPD (Path Abs File -> Either RawPackageLocationImmutable (Path Abs File)
forall a b. b -> Either a b
Right Path Abs File
cabalfp) ByteString
bs
            PackageName -> Path Abs File -> m ()
forall (m :: * -> *).
MonadThrow m =>
PackageName -> Path Abs File -> m ()
checkCabalFileName (GenericPackageDescription -> PackageName
gpdPackageName GenericPackageDescription
gpd) Path Abs File
cabalfp
            ([PWarning], GenericPackageDescription)
-> m ([PWarning], GenericPackageDescription)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([PWarning]
warnings0, GenericPackageDescription
gpd)
      [PWarning]
warnings <-
        case PrintWarnings
printWarnings of
          PrintWarnings
YesPrintWarnings -> (PWarning -> m ()) -> [PWarning] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> m ())
-> (PWarning -> Utf8Builder) -> PWarning -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> PWarning -> Utf8Builder
toPretty Path Abs File
cabalfp) [PWarning]
warnings0 m () -> [PWarning] -> m [PWarning]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> []
          PrintWarnings
NoPrintWarnings -> [PWarning] -> m [PWarning]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [PWarning]
warnings0
      IORef (Maybe ([PWarning], GenericPackageDescription))
-> Maybe ([PWarning], GenericPackageDescription) -> m ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef (Maybe ([PWarning], GenericPackageDescription))
gpdRef (Maybe ([PWarning], GenericPackageDescription) -> m ())
-> Maybe ([PWarning], GenericPackageDescription) -> m ()
forall a b. (a -> b) -> a -> b
$ ([PWarning], GenericPackageDescription)
-> Maybe ([PWarning], GenericPackageDescription)
forall a. a -> Maybe a
Just ([PWarning]
warnings, GenericPackageDescription
gpd)
      GenericPackageDescription -> m GenericPackageDescription
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenericPackageDescription
gpd

    toPretty :: Path Abs File -> PWarning -> Utf8Builder
    toPretty :: Path Abs File -> PWarning -> Utf8Builder
toPretty Path Abs File
src (PWarning PWarnType
_type Position
pos FilePath
msg) =
      Utf8Builder
"Cabal file warning in" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
      FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
src) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"@" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
      FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (Position -> FilePath
showPos Position
pos) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
      FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString FilePath
msg

    -- | Check if the given name in the @Package@ matches the name of the .cabal file
    checkCabalFileName :: MonadThrow m => PackageName -> Path Abs File -> m ()
    checkCabalFileName :: PackageName -> Path Abs File -> m ()
checkCabalFileName PackageName
name Path Abs File
cabalfp = do
        -- Previously, we just use parsePackageNameFromFilePath. However, that can
        -- lead to confusing error messages. See:
        -- https://github.com/commercialhaskell/stack/issues/895
        let expected :: FilePath
expected = Text -> FilePath
T.unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ SafeFilePath -> Text
unSafeFilePath (SafeFilePath -> Text) -> SafeFilePath -> Text
forall a b. (a -> b) -> a -> b
$ PackageName -> SafeFilePath
cabalFileName PackageName
name
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath
expected FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= Path Rel File -> FilePath
forall b t. Path b t -> FilePath
toFilePath (Path Abs File -> Path Rel File
forall b. Path b File -> Path Rel File
filename Path Abs File
cabalfp))
            (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ PantryException -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (PantryException -> m ()) -> PantryException -> m ()
forall a b. (a -> b) -> a -> b
$ Path Abs File -> PackageName -> PantryException
MismatchedCabalName Path Abs File
cabalfp PackageName
name

-- | 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.
--
-- @since 0.1.0.0
findOrGenerateCabalFile
    :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
    => Path Abs Dir -- ^ package directory
    -> RIO env (PackageName, Path Abs File)
findOrGenerateCabalFile :: 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 ((FilePath -> FilePath -> Bool) -> FilePath -> FilePath -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip FilePath -> FilePath -> Bool
hasExtension FilePath
"cabal" (FilePath -> Bool)
-> (Path Abs File -> FilePath) -> Path Abs File -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> FilePath
forall b t. Path b t -> FilePath
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 unixlike 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 :: FilePath -> Bool
isHidden (Char
'.':FilePath
_) = Bool
True
        isHidden FilePath
_ = 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
. FilePath -> Bool
isHidden (FilePath -> Bool)
-> (Path Abs File -> FilePath) -> Path Abs File -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Rel File -> FilePath
forall b t. Path b t -> FilePath
toFilePath (Path Rel File -> FilePath)
-> (Path Abs File -> Path Rel File) -> Path Abs File -> FilePath
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
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
InvalidCabalFilePath Path Abs File
x)
          (\PackageName
pn -> (PackageName, Path Abs File)
-> RIO env (PackageName, Path Abs File)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((PackageName, Path Abs File)
 -> RIO env (PackageName, Path Abs File))
-> (PackageName, Path Abs File)
-> RIO env (PackageName, Path Abs File)
forall a b. (a -> b) -> a -> b
$ (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
$
            FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripSuffix FilePath
".cabal" (Path Rel File -> FilePath
forall b t. Path b t -> FilePath
toFilePath (Path Abs File -> Path Rel File
forall b. Path b File -> Path Rel File
filename Path Abs File
x)) Maybe FilePath
-> (FilePath -> Maybe PackageName) -> Maybe PackageName
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
            FilePath -> Maybe PackageName
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
MultipleCabalFilesFound Path Abs Dir
pkgDir [Path Abs File]
files
      where hasExtension :: FilePath -> FilePath -> Bool
hasExtension FilePath
fp FilePath
x = FilePath -> FilePath
FilePath.takeExtension FilePath
fp FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"." FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
x

-- | Generate .cabal file from package.yaml, if necessary.
hpack
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => Path Abs Dir
  -> RIO env ()
hpack :: Path Abs Dir -> RIO env ()
hpack Path Abs Dir
pkgDir = do
    Path Rel File
packageConfigRelFile <- FilePath -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel File)
parseRelFile FilePath
Hpack.packageConfig
    let hpackFile :: Path Abs File
hpackFile = Path Abs Dir
pkgDir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
packageConfigRelFile
    Bool
exists <- IO Bool -> RIO env Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> RIO env Bool) -> IO Bool -> RIO env Bool
forall a b. (a -> b) -> a -> b
$ Path Abs File -> IO Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
hpackFile
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
        Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Running hpack on " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
hpackFile)

        HpackExecutable
he <- Getting HpackExecutable env HpackExecutable
-> RIO env HpackExecutable
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting HpackExecutable env HpackExecutable
 -> RIO env HpackExecutable)
-> Getting HpackExecutable env HpackExecutable
-> RIO env HpackExecutable
forall a b. (a -> b) -> a -> b
$ (PantryConfig -> Const HpackExecutable PantryConfig)
-> env -> Const HpackExecutable env
forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigL((PantryConfig -> Const HpackExecutable PantryConfig)
 -> env -> Const HpackExecutable env)
-> ((HpackExecutable -> Const HpackExecutable HpackExecutable)
    -> PantryConfig -> Const HpackExecutable PantryConfig)
-> Getting HpackExecutable env HpackExecutable
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PantryConfig -> HpackExecutable)
-> SimpleGetter PantryConfig HpackExecutable
forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig -> HpackExecutable
pcHpackExecutable
        case HpackExecutable
he of
            HpackExecutable
HpackBundled -> do
                Result
r <- IO Result -> RIO env Result
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Result -> RIO env Result) -> IO Result -> RIO env Result
forall a b. (a -> b) -> a -> b
$ Options -> IO Result
Hpack.hpackResult (Options -> IO Result) -> Options -> IO Result
forall a b. (a -> b) -> a -> b
$ ProgramName -> Options -> Options
Hpack.setProgramName ProgramName
"stack" (Options -> Options) -> Options -> Options
forall a b. (a -> b) -> a -> b
$ FilePath -> Options -> Options
Hpack.setTarget (Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
hpackFile) Options
Hpack.defaultOptions
                [FilePath] -> (FilePath -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Result -> [FilePath]
Hpack.resultWarnings Result
r) (Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ())
-> (FilePath -> Utf8Builder) -> FilePath -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString)
                let cabalFile :: Utf8Builder
cabalFile = FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (FilePath -> Utf8Builder)
-> (Result -> FilePath) -> Result -> Utf8Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> FilePath
Hpack.resultCabalFile (Result -> Utf8Builder) -> Result -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ Result
r
                case Result -> Status
Hpack.resultStatus Result
r of
                    Status
Hpack.Generated -> Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"hpack generated a modified version of " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
cabalFile
                    Status
Hpack.OutputUnchanged -> Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"hpack output unchanged in " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
cabalFile
                    Status
Hpack.AlreadyGeneratedByNewerHpack -> 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
cabalFile Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                        Utf8Builder
" was generated with a newer version of hpack,\n" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                        Utf8Builder
"please upgrade and try again."
                    Status
Hpack.ExistingCabalFileWasModifiedManually -> 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
cabalFile Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                        Utf8Builder
" was modified manually. Ignoring " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                        FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
hpackFile) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                        Utf8Builder
" in favor of the cabal file.\nIf you want to use the " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                        FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (Path Rel File -> FilePath
forall b t. Path b t -> FilePath
toFilePath (Path Abs File -> Path Rel File
forall b. Path b File -> Path Rel File
filename Path Abs File
hpackFile)) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                        Utf8Builder
" file instead of the cabal file,\n" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                        Utf8Builder
"then please delete the cabal file."
            HpackCommand FilePath
command ->
                FilePath -> RIO env () -> RIO env ()
forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
FilePath -> m a -> m a
withWorkingDir (Path Abs Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
pkgDir) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
                FilePath
-> [FilePath]
-> (ProcessConfig () () () -> RIO env ())
-> RIO env ()
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
FilePath -> [FilePath] -> (ProcessConfig () () () -> m a) -> m a
proc FilePath
command [] ProcessConfig () () () -> RIO env ()
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_

-- | Get the 'PackageIdentifier' from a 'GenericPackageDescription'.
--
-- @since 0.1.0.0
gpdPackageIdentifier :: GenericPackageDescription -> PackageIdentifier
gpdPackageIdentifier :: GenericPackageDescription -> PackageIdentifier
gpdPackageIdentifier = PackageDescription -> PackageIdentifier
D.package (PackageDescription -> PackageIdentifier)
-> (GenericPackageDescription -> PackageDescription)
-> GenericPackageDescription
-> PackageIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericPackageDescription -> PackageDescription
D.packageDescription

-- | Get the 'PackageName' from a 'GenericPackageDescription'.
--
-- @since 0.1.0.0
gpdPackageName :: GenericPackageDescription -> PackageName
gpdPackageName :: GenericPackageDescription -> PackageName
gpdPackageName = PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> (GenericPackageDescription -> PackageIdentifier)
-> GenericPackageDescription
-> PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericPackageDescription -> PackageIdentifier
gpdPackageIdentifier

-- | Get the 'Version' from a 'GenericPackageDescription'.
--
-- @since 0.1.0.0
gpdVersion :: GenericPackageDescription -> Version
gpdVersion :: GenericPackageDescription -> Version
gpdVersion = PackageIdentifier -> Version
pkgVersion (PackageIdentifier -> Version)
-> (GenericPackageDescription -> PackageIdentifier)
-> GenericPackageDescription
-> Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericPackageDescription -> PackageIdentifier
gpdPackageIdentifier

loadCabalFileBytes
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => PackageLocationImmutable
  -> RIO env ByteString

-- Just ignore the mtree for this. Safe assumption: someone who filled
-- in the TreeKey also filled in the cabal file hash, and that's a
-- more efficient lookup mechanism.
loadCabalFileBytes :: PackageLocationImmutable -> RIO env ByteString
loadCabalFileBytes (PLIHackage PackageIdentifier
pident BlobKey
cfHash TreeKey
_mtree) = PackageIdentifierRevision -> RIO env ByteString
forall env.
(HasPantryConfig env, HasLogFunc env) =>
PackageIdentifierRevision -> RIO env ByteString
getHackageCabalFile (PackageIdentifier -> BlobKey -> PackageIdentifierRevision
pirForHash PackageIdentifier
pident BlobKey
cfHash)

loadCabalFileBytes PackageLocationImmutable
pl = do
  Package
package <- PackageLocationImmutable -> RIO env Package
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageLocationImmutable -> RIO env Package
loadPackage PackageLocationImmutable
pl
  let sfp :: SafeFilePath
sfp = PackageName -> SafeFilePath
cabalFileName (PackageName -> SafeFilePath) -> PackageName -> SafeFilePath
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> PackageIdentifier -> PackageName
forall a b. (a -> b) -> a -> b
$ Package -> PackageIdentifier
packageIdent Package
package
  BlobKey
cabalBlobKey <- case (Package -> PackageCabal
packageCabalEntry Package
package) of
                       PCHpack PHpack
pcHpack -> BlobKey -> RIO env BlobKey
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BlobKey -> RIO env BlobKey) -> BlobKey -> RIO env BlobKey
forall a b. (a -> b) -> a -> b
$ TreeEntry -> BlobKey
teBlob (TreeEntry -> BlobKey)
-> (PHpack -> TreeEntry) -> PHpack -> BlobKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PHpack -> TreeEntry
phGenerated (PHpack -> BlobKey) -> PHpack -> BlobKey
forall a b. (a -> b) -> a -> b
$ PHpack
pcHpack
                       PCCabalFile (TreeEntry BlobKey
blobKey FileType
_) -> BlobKey -> RIO env BlobKey
forall (f :: * -> *) a. Applicative f => a -> f a
pure BlobKey
blobKey
  Maybe ByteString
mbs <- ReaderT SqlBackend (RIO env) (Maybe ByteString)
-> RIO env (Maybe ByteString)
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) (Maybe ByteString)
 -> RIO env (Maybe ByteString))
-> ReaderT SqlBackend (RIO env) (Maybe ByteString)
-> RIO env (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ BlobKey -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
forall env.
HasLogFunc env =>
BlobKey -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
loadBlob BlobKey
cabalBlobKey
  case Maybe ByteString
mbs of
    Maybe ByteString
Nothing -> do
      PantryException -> RIO env ByteString
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env ByteString)
-> PantryException -> RIO env ByteString
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable
-> SafeFilePath -> BlobKey -> PantryException
TreeReferencesMissingBlob (PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI PackageLocationImmutable
pl) SafeFilePath
sfp BlobKey
cabalBlobKey
    Just ByteString
bs -> ByteString -> RIO env ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs

-- FIXME: to be removed
loadRawCabalFileBytes
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => RawPackageLocationImmutable
  -> RIO env ByteString

-- Just ignore the mtree for this. Safe assumption: someone who filled
-- in the TreeKey also filled in the cabal file hash, and that's a
-- more efficient lookup mechanism.
loadRawCabalFileBytes :: RawPackageLocationImmutable -> RIO env ByteString
loadRawCabalFileBytes (RPLIHackage PackageIdentifierRevision
pir Maybe TreeKey
_mtree) = PackageIdentifierRevision -> RIO env ByteString
forall env.
(HasPantryConfig env, HasLogFunc env) =>
PackageIdentifierRevision -> RIO env ByteString
getHackageCabalFile PackageIdentifierRevision
pir

loadRawCabalFileBytes RawPackageLocationImmutable
pl = do
  Package
package <- RawPackageLocationImmutable -> RIO env Package
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env Package
loadPackageRaw RawPackageLocationImmutable
pl
  let sfp :: SafeFilePath
sfp = PackageName -> SafeFilePath
cabalFileName (PackageName -> SafeFilePath) -> PackageName -> SafeFilePath
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> PackageIdentifier -> PackageName
forall a b. (a -> b) -> a -> b
$ Package -> PackageIdentifier
packageIdent Package
package
      TreeEntry BlobKey
cabalBlobKey FileType
_ft = case Package -> PackageCabal
packageCabalEntry Package
package of
                                     PCCabalFile TreeEntry
cabalTE -> TreeEntry
cabalTE
                                     PCHpack PHpack
hpackCE -> PHpack -> TreeEntry
phGenerated PHpack
hpackCE
  Maybe ByteString
mbs <- ReaderT SqlBackend (RIO env) (Maybe ByteString)
-> RIO env (Maybe ByteString)
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) (Maybe ByteString)
 -> RIO env (Maybe ByteString))
-> ReaderT SqlBackend (RIO env) (Maybe ByteString)
-> RIO env (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ BlobKey -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
forall env.
HasLogFunc env =>
BlobKey -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
loadBlob BlobKey
cabalBlobKey
  case Maybe ByteString
mbs of
    Maybe ByteString
Nothing -> do
      PantryException -> RIO env ByteString
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env ByteString)
-> PantryException -> RIO env ByteString
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable
-> SafeFilePath -> BlobKey -> PantryException
TreeReferencesMissingBlob RawPackageLocationImmutable
pl SafeFilePath
sfp BlobKey
cabalBlobKey
    Just ByteString
bs -> ByteString -> RIO env ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs

-- | Load a 'Package' from a 'PackageLocationImmutable'.
--
-- @since 0.1.0.0
loadPackage
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => PackageLocationImmutable
  -> RIO env Package
loadPackage :: PackageLocationImmutable -> RIO env Package
loadPackage = RawPackageLocationImmutable -> RIO env Package
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env Package
loadPackageRaw (RawPackageLocationImmutable -> RIO env Package)
-> (PackageLocationImmutable -> RawPackageLocationImmutable)
-> PackageLocationImmutable
-> RIO env Package
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI

-- | Load a 'Package' from a 'RawPackageLocationImmutable'.
--
-- Load the package either from the local DB, Casa, or as a last
-- resort, the third party (hackage, archive or repo).
--
-- @since 0.1.0.0
loadPackageRaw
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => RawPackageLocationImmutable
  -> RIO env Package
loadPackageRaw :: RawPackageLocationImmutable -> RIO env Package
loadPackageRaw RawPackageLocationImmutable
rpli = do
  case RawPackageLocationImmutable -> Maybe TreeKey
getRawTreeKey RawPackageLocationImmutable
rpli of
    Just TreeKey
treeKey' -> do
      Maybe Package
mpackage <- RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
forall env.
(HasLogFunc env, HasPantryConfig env, HasProcessContext env) =>
RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
tryLoadPackageRawViaDbOrCasa RawPackageLocationImmutable
rpli TreeKey
treeKey'
      case Maybe Package
mpackage of
        Maybe Package
Nothing -> RIO env Package
loadPackageRawViaThirdParty
        Just Package
package -> Package -> RIO env Package
forall (f :: * -> *) a. Applicative f => a -> f a
pure Package
package
    Maybe TreeKey
Nothing -> RIO env Package
loadPackageRawViaThirdParty
  where
    loadPackageRawViaThirdParty :: RIO env Package
loadPackageRawViaThirdParty = do
      Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Loading package from third-party: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> RawPackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
rpli)
      case RawPackageLocationImmutable
rpli of
        RPLIHackage PackageIdentifierRevision
pir Maybe TreeKey
mtree -> HackageTarballResult -> Package
htrPackage (HackageTarballResult -> Package)
-> RIO env HackageTarballResult -> RIO env Package
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageIdentifierRevision
-> Maybe TreeKey -> RIO env HackageTarballResult
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageIdentifierRevision
-> Maybe TreeKey -> RIO env HackageTarballResult
getHackageTarball PackageIdentifierRevision
pir Maybe TreeKey
mtree
        RPLIArchive RawArchive
archive RawPackageMetadata
pm -> RawPackageLocationImmutable
-> RawArchive -> RawPackageMetadata -> RIO env Package
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env,
 HasCallStack) =>
RawPackageLocationImmutable
-> RawArchive -> RawPackageMetadata -> RIO env Package
getArchivePackage RawPackageLocationImmutable
rpli RawArchive
archive RawPackageMetadata
pm
        RPLIRepo Repo
repo RawPackageMetadata
rpm -> Repo -> RawPackageMetadata -> RIO env Package
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Repo -> RawPackageMetadata -> RIO env Package
getRepo Repo
repo RawPackageMetadata
rpm

-- | Try to load a package via the database or Casa.
tryLoadPackageRawViaDbOrCasa ::
     (HasLogFunc env, HasPantryConfig env, HasProcessContext env)
  => RawPackageLocationImmutable
  -> TreeKey
  -> RIO env (Maybe Package)
tryLoadPackageRawViaDbOrCasa :: RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
tryLoadPackageRawViaDbOrCasa RawPackageLocationImmutable
rpli TreeKey
treeKey' = do
  Maybe Package
mviaDb <- RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
forall env.
(HasLogFunc env, HasPantryConfig env, HasProcessContext env) =>
RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
tryLoadPackageRawViaLocalDb RawPackageLocationImmutable
rpli TreeKey
treeKey'
  case Maybe Package
mviaDb of
    Just Package
package -> do
      Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Loaded package from Pantry: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> RawPackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
rpli)
      Maybe Package -> RIO env (Maybe Package)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Package -> Maybe Package
forall a. a -> Maybe a
Just Package
package)
    Maybe Package
Nothing -> do
      Maybe Package
mviaCasa <- RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
forall env.
(HasLogFunc env, HasPantryConfig env, HasProcessContext env) =>
RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
tryLoadPackageRawViaCasa RawPackageLocationImmutable
rpli TreeKey
treeKey'
      case Maybe Package
mviaCasa of
        Just Package
package -> do
          Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Loaded package from Casa: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> RawPackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
rpli)
          Maybe Package -> RIO env (Maybe Package)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Package -> Maybe Package
forall a. a -> Maybe a
Just Package
package)
        Maybe Package
Nothing -> Maybe Package -> RIO env (Maybe Package)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Package
forall a. Maybe a
Nothing

-- | Maybe load the package from Casa.
tryLoadPackageRawViaCasa ::
     (HasLogFunc env, HasPantryConfig env, HasProcessContext env)
  => RawPackageLocationImmutable
  -> TreeKey
  -> RIO env (Maybe Package)
tryLoadPackageRawViaCasa :: RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
tryLoadPackageRawViaCasa RawPackageLocationImmutable
rlpi TreeKey
treeKey' = do
  Maybe (TreeKey, Tree)
mtreePair <- TreeKey -> RIO env (Maybe (TreeKey, Tree))
forall env.
(HasPantryConfig env, HasLogFunc env) =>
TreeKey -> RIO env (Maybe (TreeKey, Tree))
casaLookupTree TreeKey
treeKey'
  case Maybe (TreeKey, Tree)
mtreePair of
    Maybe (TreeKey, Tree)
Nothing -> Maybe Package -> RIO env (Maybe Package)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Package
forall a. Maybe a
Nothing
    Just (TreeKey
treeKey'', Tree
_tree) -> do
      [RawPackageLocationImmutable] -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
[RawPackageLocationImmutable] -> RIO env ()
fetchTreeKeys [RawPackageLocationImmutable
rlpi]
      Maybe Package
mdb <- RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
forall env.
(HasLogFunc env, HasPantryConfig env, HasProcessContext env) =>
RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
tryLoadPackageRawViaLocalDb RawPackageLocationImmutable
rlpi TreeKey
treeKey''
      case Maybe Package
mdb of
        Maybe Package
Nothing -> do
          Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn
            (Utf8Builder
"Did not find tree key in DB after pulling it from Casa: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
             TreeKey -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display TreeKey
treeKey'' Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
             Utf8Builder
" (for " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
             RawPackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
rlpi Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
             Utf8Builder
")")
          Maybe Package -> RIO env (Maybe Package)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Package
forall a. Maybe a
Nothing
        Just Package
package -> Maybe Package -> RIO env (Maybe Package)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Package -> Maybe Package
forall a. a -> Maybe a
Just Package
package)

-- | Maybe load the package from the local database.
tryLoadPackageRawViaLocalDb ::
     (HasLogFunc env, HasPantryConfig env, HasProcessContext env)
  => RawPackageLocationImmutable
  -> TreeKey
  -> RIO env (Maybe Package)
tryLoadPackageRawViaLocalDb :: RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
tryLoadPackageRawViaLocalDb RawPackageLocationImmutable
rlpi TreeKey
treeKey' = do
  Maybe (Entity Tree)
mtreeEntity <- ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
-> RIO env (Maybe (Entity Tree))
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
forall env.
TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
getTreeForKey TreeKey
treeKey')
  case Maybe (Entity Tree)
mtreeEntity of
    Maybe (Entity Tree)
Nothing -> Maybe Package -> RIO env (Maybe Package)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Package
forall a. Maybe a
Nothing
    Just Entity Tree
treeId ->
      (Package -> Maybe Package)
-> RIO env Package -> RIO env (Maybe Package)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Package -> Maybe Package
forall a. a -> Maybe a
Just (ReaderT SqlBackend (RIO env) Package -> RIO env Package
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (RawPackageLocationImmutable
-> TreeId -> ReaderT SqlBackend (RIO env) Package
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> TreeId -> ReaderT SqlBackend (RIO env) Package
loadPackageById RawPackageLocationImmutable
rlpi (Entity Tree -> TreeId
forall record. Entity record -> Key record
entityKey Entity Tree
treeId)))

-- | Complete package location, plus whether the package has a cabal file. This
-- is relevant to reproducibility, see
-- <https://tech.fpcomplete.com/blog/storing-generated-cabal-files>
--
-- @since 0.4.0.0
data CompletePackageLocation = CompletePackageLocation
  { CompletePackageLocation -> PackageLocationImmutable
cplComplete :: !PackageLocationImmutable
  , CompletePackageLocation -> Bool
cplHasCabalFile :: !Bool
  }

-- | Fill in optional fields in a 'PackageLocationImmutable' for more reproducible builds.
--
-- @since 0.1.0.0
completePackageLocation
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => RawPackageLocationImmutable
  -> RIO env CompletePackageLocation
completePackageLocation :: RawPackageLocationImmutable -> RIO env CompletePackageLocation
completePackageLocation (RPLIHackage (PackageIdentifierRevision PackageName
n Version
v (CFIHash SHA256
sha (Just FileSize
size))) (Just TreeKey
tk)) =
  CompletePackageLocation -> RIO env CompletePackageLocation
forall (f :: * -> *) a. Applicative f => a -> f a
pure CompletePackageLocation :: PackageLocationImmutable -> Bool -> CompletePackageLocation
CompletePackageLocation
    { cplComplete :: PackageLocationImmutable
cplComplete = PackageIdentifier -> BlobKey -> TreeKey -> PackageLocationImmutable
PLIHackage (PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
n Version
v) (SHA256 -> FileSize -> BlobKey
BlobKey SHA256
sha FileSize
size) TreeKey
tk
    , cplHasCabalFile :: Bool
cplHasCabalFile = Bool
True
    }
completePackageLocation (RPLIHackage pir0 :: PackageIdentifierRevision
pir0@(PackageIdentifierRevision PackageName
name Version
version CabalFileInfo
cfi0) Maybe TreeKey
_) = do
  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Completing package location information from " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> PackageIdentifierRevision -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display PackageIdentifierRevision
pir0
  (PackageIdentifierRevision
pir, BlobKey
cfKey) <-
    case CabalFileInfo
cfi0 of
      CFIHash SHA256
sha (Just FileSize
size) -> (PackageIdentifierRevision, BlobKey)
-> RIO env (PackageIdentifierRevision, BlobKey)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageIdentifierRevision
pir0, SHA256 -> FileSize -> BlobKey
BlobKey SHA256
sha FileSize
size)
      CabalFileInfo
_ -> do
        ByteString
bs <- PackageIdentifierRevision -> RIO env ByteString
forall env.
(HasPantryConfig env, HasLogFunc env) =>
PackageIdentifierRevision -> RIO env ByteString
getHackageCabalFile PackageIdentifierRevision
pir0
        let size :: FileSize
size = Word -> FileSize
FileSize (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
bs))
            sha :: SHA256
sha = ByteString -> SHA256
SHA256.hashBytes ByteString
bs
            cfi :: CabalFileInfo
cfi = SHA256 -> Maybe FileSize -> CabalFileInfo
CFIHash SHA256
sha (FileSize -> Maybe FileSize
forall a. a -> Maybe a
Just FileSize
size)
            pir :: PackageIdentifierRevision
pir = PackageName
-> Version -> CabalFileInfo -> PackageIdentifierRevision
PackageIdentifierRevision PackageName
name Version
version CabalFileInfo
cfi
        Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Added in cabal file hash: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> PackageIdentifierRevision -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display PackageIdentifierRevision
pir
        (PackageIdentifierRevision, BlobKey)
-> RIO env (PackageIdentifierRevision, BlobKey)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageIdentifierRevision
pir, SHA256 -> FileSize -> BlobKey
BlobKey SHA256
sha FileSize
size)
  TreeKey
treeKey' <- PackageIdentifierRevision -> RIO env TreeKey
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageIdentifierRevision -> RIO env TreeKey
getHackageTarballKey PackageIdentifierRevision
pir
  CompletePackageLocation -> RIO env CompletePackageLocation
forall (f :: * -> *) a. Applicative f => a -> f a
pure CompletePackageLocation :: PackageLocationImmutable -> Bool -> CompletePackageLocation
CompletePackageLocation
    { cplComplete :: PackageLocationImmutable
cplComplete = PackageIdentifier -> BlobKey -> TreeKey -> PackageLocationImmutable
PLIHackage (PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version) BlobKey
cfKey TreeKey
treeKey'
    , cplHasCabalFile :: Bool
cplHasCabalFile = Bool
True
    }
completePackageLocation pl :: RawPackageLocationImmutable
pl@(RPLIArchive RawArchive
archive RawPackageMetadata
rpm) = do
  Maybe Package
mpackage <-
    case RawPackageMetadata -> Maybe TreeKey
rpmTreeKey RawPackageMetadata
rpm of
      Just TreeKey
treeKey' -> RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
forall env.
(HasLogFunc env, HasPantryConfig env, HasProcessContext env) =>
RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
tryLoadPackageRawViaDbOrCasa RawPackageLocationImmutable
pl TreeKey
treeKey'
      Maybe TreeKey
Nothing -> Maybe Package -> RIO env (Maybe Package)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Package
forall a. Maybe a
Nothing
  case (,,) (SHA256 -> FileSize -> Package -> (SHA256, FileSize, Package))
-> Maybe SHA256
-> Maybe (FileSize -> Package -> (SHA256, FileSize, Package))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawArchive -> Maybe SHA256
raHash RawArchive
archive Maybe (FileSize -> Package -> (SHA256, FileSize, Package))
-> Maybe FileSize -> Maybe (Package -> (SHA256, FileSize, Package))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RawArchive -> Maybe FileSize
raSize RawArchive
archive Maybe (Package -> (SHA256, FileSize, Package))
-> Maybe Package -> Maybe (SHA256, FileSize, Package)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Package
mpackage of
    Just (SHA256
sha256, FileSize
fileSize, Package
package) -> do
      let RawArchive ArchiveLocation
loc Maybe SHA256
_ Maybe FileSize
_ Text
subdir = RawArchive
archive
      CompletePackageLocation -> RIO env CompletePackageLocation
forall (f :: * -> *) a. Applicative f => a -> f a
pure CompletePackageLocation :: PackageLocationImmutable -> Bool -> CompletePackageLocation
CompletePackageLocation
        { cplComplete :: PackageLocationImmutable
cplComplete = Archive -> PackageMetadata -> PackageLocationImmutable
PLIArchive (ArchiveLocation -> SHA256 -> FileSize -> Text -> Archive
Archive ArchiveLocation
loc SHA256
sha256 FileSize
fileSize Text
subdir) (Package -> PackageMetadata
packagePM Package
package)
        , cplHasCabalFile :: Bool
cplHasCabalFile =
            case Package -> PackageCabal
packageCabalEntry Package
package of
              PCCabalFile{} -> Bool
True
              PCHpack{} -> Bool
False
        }
    Maybe (SHA256, FileSize, Package)
Nothing -> Bool -> RIO env CompletePackageLocation
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Bool -> RIO env CompletePackageLocation
byThirdParty (Maybe Package -> Bool
forall a. Maybe a -> Bool
isJust Maybe Package
mpackage)
  where
    byThirdParty :: Bool -> RIO env CompletePackageLocation
byThirdParty Bool
warnAboutMissingSizeSha = do
      (SHA256
sha, FileSize
size, Package
package, CachedTree
_cachedTree) <- RawPackageLocationImmutable
-> RawArchive
-> RawPackageMetadata
-> RIO env (SHA256, FileSize, Package, CachedTree)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env,
 HasCallStack) =>
RawPackageLocationImmutable
-> RawArchive
-> RawPackageMetadata
-> RIO env (SHA256, FileSize, Package, CachedTree)
getArchive RawPackageLocationImmutable
pl RawArchive
archive RawPackageMetadata
rpm
      Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
warnAboutMissingSizeSha (SHA256 -> FileSize -> RIO env ()
forall (m :: * -> *) env a a.
(MonadIO m, MonadReader env m, HasLogFunc env, Display a,
 Display a) =>
a -> a -> m ()
warnWith SHA256
sha FileSize
size)
      -- (getArchive checks archive and package metadata)
      let RawArchive ArchiveLocation
loc Maybe SHA256
_ Maybe FileSize
_ Text
subdir = RawArchive
archive
      Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (FilePath -> Utf8Builder) -> FilePath -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ (RawPackageLocationImmutable, SHA256, FileSize, Package)
-> FilePath
forall a. Show a => a -> FilePath
show (RawPackageLocationImmutable
pl, SHA256
sha, FileSize
size, Package
package)
      CompletePackageLocation -> RIO env CompletePackageLocation
forall (f :: * -> *) a. Applicative f => a -> f a
pure CompletePackageLocation :: PackageLocationImmutable -> Bool -> CompletePackageLocation
CompletePackageLocation
        { cplComplete :: PackageLocationImmutable
cplComplete = Archive -> PackageMetadata -> PackageLocationImmutable
PLIArchive (ArchiveLocation -> SHA256 -> FileSize -> Text -> Archive
Archive ArchiveLocation
loc SHA256
sha FileSize
size Text
subdir) (Package -> PackageMetadata
packagePM Package
package)
        , cplHasCabalFile :: Bool
cplHasCabalFile =
            case Package -> PackageCabal
packageCabalEntry Package
package of
              PCCabalFile{} -> Bool
True
              PCHpack{} -> Bool
False
        }
    warnWith :: a -> a -> m ()
warnWith a
sha a
size =
      Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn
        ([Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat
           [ Utf8Builder
"The package "
           , RawPackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
pl
           , Utf8Builder
" is available from the local content-addressable storage database, \n"
           , Utf8Builder
"but we can't use it unless you specify the size and hash for this package.\n"
           , Utf8Builder
"Add the following to your package description:\n"
           , Utf8Builder
"\nsize: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> a -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display a
size
           , Utf8Builder
"\nsha256: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> a -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display a
sha
           ])
completePackageLocation pl :: RawPackageLocationImmutable
pl@(RPLIRepo Repo
repo RawPackageMetadata
rpm) = do
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
isSHA1 (Repo -> Text
repoCommit Repo
repo)) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ PantryException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env ()) -> PantryException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Repo -> PantryException
CannotCompleteRepoNonSHA1 Repo
repo
  Repo
-> RawPackageLocationImmutable
-> RawPackageMetadata
-> RIO env CompletePackageLocation
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Repo
-> RawPackageLocationImmutable
-> RawPackageMetadata
-> RIO env CompletePackageLocation
completePM Repo
repo RawPackageLocationImmutable
pl RawPackageMetadata
rpm
  where
    isSHA1 :: Text -> Bool
isSHA1 Text
t = Text -> Int
T.length Text
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
40 Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isHexDigit Text
t

completePM
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => Repo
  -> RawPackageLocationImmutable
  -> RawPackageMetadata
  -> RIO env CompletePackageLocation
completePM :: Repo
-> RawPackageLocationImmutable
-> RawPackageMetadata
-> RIO env CompletePackageLocation
completePM Repo
repo RawPackageLocationImmutable
plOrig rpm :: RawPackageMetadata
rpm@(RawPackageMetadata Maybe PackageName
mn Maybe Version
mv Maybe TreeKey
mtk)
  | Just PackageName
n <- Maybe PackageName
mn, Just Version
v <- Maybe Version
mv, Just TreeKey
tk <- Maybe TreeKey
mtk = do
      let pm :: PackageMetadata
pm = PackageIdentifier -> TreeKey -> PackageMetadata
PackageMetadata (PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
n Version
v) TreeKey
tk
      CompletePackageLocation -> RIO env CompletePackageLocation
forall (f :: * -> *) a. Applicative f => a -> f a
pure CompletePackageLocation :: PackageLocationImmutable -> Bool -> CompletePackageLocation
CompletePackageLocation
        { cplComplete :: PackageLocationImmutable
cplComplete = Repo -> PackageMetadata -> PackageLocationImmutable
PLIRepo Repo
repo PackageMetadata
pm
        -- This next bit is a hack: we don't know for certain that this is the case.
        -- However, for the use case where complete package metadata has been supplied,
        -- we'll assume there's a cabal file for purposes of generating a deprecation warning.
        , cplHasCabalFile :: Bool
cplHasCabalFile = Bool
True
        }
  | Bool
otherwise = do
      Package
package <- RawPackageLocationImmutable -> RIO env Package
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env Package
loadPackageRaw RawPackageLocationImmutable
plOrig
      let pm :: PackageMetadata
pm = Package -> PackageMetadata
packagePM Package
package
      let isSame :: a -> Maybe a -> Bool
isSame a
x (Just a
y) = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y
          isSame a
_ Maybe a
_ = Bool
True

          allSame :: Bool
allSame =
            PackageName -> Maybe PackageName -> Bool
forall a. Eq a => a -> Maybe a -> Bool
isSame (PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> PackageIdentifier -> PackageName
forall a b. (a -> b) -> a -> b
$ PackageMetadata -> PackageIdentifier
pmIdent PackageMetadata
pm) (RawPackageMetadata -> Maybe PackageName
rpmName RawPackageMetadata
rpm) Bool -> Bool -> Bool
&&
            Version -> Maybe Version -> Bool
forall a. Eq a => a -> Maybe a -> Bool
isSame (PackageIdentifier -> Version
pkgVersion (PackageIdentifier -> Version) -> PackageIdentifier -> Version
forall a b. (a -> b) -> a -> b
$ PackageMetadata -> PackageIdentifier
pmIdent PackageMetadata
pm) (RawPackageMetadata -> Maybe Version
rpmVersion RawPackageMetadata
rpm) Bool -> Bool -> Bool
&&
            TreeKey -> Maybe TreeKey -> Bool
forall a. Eq a => a -> Maybe a -> Bool
isSame (PackageMetadata -> TreeKey
pmTreeKey PackageMetadata
pm) (RawPackageMetadata -> Maybe TreeKey
rpmTreeKey RawPackageMetadata
rpm)
      if Bool
allSame
        then CompletePackageLocation -> RIO env CompletePackageLocation
forall (f :: * -> *) a. Applicative f => a -> f a
pure CompletePackageLocation :: PackageLocationImmutable -> Bool -> CompletePackageLocation
CompletePackageLocation
               { cplComplete :: PackageLocationImmutable
cplComplete = Repo -> PackageMetadata -> PackageLocationImmutable
PLIRepo Repo
repo PackageMetadata
pm
               , cplHasCabalFile :: Bool
cplHasCabalFile =
                   case Package -> PackageCabal
packageCabalEntry Package
package of
                     PCCabalFile{} -> Bool
True
                     PCHpack{} -> Bool
False
               }
        else PantryException -> RIO env CompletePackageLocation
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env CompletePackageLocation)
-> PantryException -> RIO env CompletePackageLocation
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable -> PackageMetadata -> PantryException
CompletePackageMetadataMismatch RawPackageLocationImmutable
plOrig PackageMetadata
pm

packagePM :: Package -> PackageMetadata
packagePM :: Package -> PackageMetadata
packagePM Package
package = PackageMetadata :: PackageIdentifier -> TreeKey -> PackageMetadata
PackageMetadata
  { pmIdent :: PackageIdentifier
pmIdent = Package -> PackageIdentifier
packageIdent Package
package
  , pmTreeKey :: TreeKey
pmTreeKey = Package -> TreeKey
packageTreeKey Package
package
  }

-- | Add in hashes to make a 'SnapshotLocation' reproducible.
--
-- @since 0.1.0.0
completeSnapshotLocation
  :: (HasPantryConfig env, HasLogFunc env)
  => RawSnapshotLocation
  -> RIO env SnapshotLocation
completeSnapshotLocation :: RawSnapshotLocation -> RIO env SnapshotLocation
completeSnapshotLocation (RSLCompiler WantedCompiler
c) = SnapshotLocation -> RIO env SnapshotLocation
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SnapshotLocation -> RIO env SnapshotLocation)
-> SnapshotLocation -> RIO env SnapshotLocation
forall a b. (a -> b) -> a -> b
$ WantedCompiler -> SnapshotLocation
SLCompiler WantedCompiler
c
completeSnapshotLocation (RSLFilePath ResolvedPath File
f) = SnapshotLocation -> RIO env SnapshotLocation
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SnapshotLocation -> RIO env SnapshotLocation)
-> SnapshotLocation -> RIO env SnapshotLocation
forall a b. (a -> b) -> a -> b
$ ResolvedPath File -> SnapshotLocation
SLFilePath ResolvedPath File
f
completeSnapshotLocation (RSLUrl Text
url (Just BlobKey
blobKey)) = SnapshotLocation -> RIO env SnapshotLocation
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SnapshotLocation -> RIO env SnapshotLocation)
-> SnapshotLocation -> RIO env SnapshotLocation
forall a b. (a -> b) -> a -> b
$ Text -> BlobKey -> SnapshotLocation
SLUrl Text
url BlobKey
blobKey
completeSnapshotLocation (RSLUrl Text
url Maybe BlobKey
Nothing) = do
  ByteString
bs <- Text -> Maybe BlobKey -> RIO env ByteString
forall env.
(HasPantryConfig env, HasLogFunc env) =>
Text -> Maybe BlobKey -> RIO env ByteString
loadFromURL Text
url Maybe BlobKey
forall a. Maybe a
Nothing
  SnapshotLocation -> RIO env SnapshotLocation
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SnapshotLocation -> RIO env SnapshotLocation)
-> SnapshotLocation -> RIO env SnapshotLocation
forall a b. (a -> b) -> a -> b
$ Text -> BlobKey -> SnapshotLocation
SLUrl Text
url (ByteString -> BlobKey
bsToBlobKey ByteString
bs)
completeSnapshotLocation (RSLSynonym SnapName
syn) =
  RawSnapshotLocation -> RIO env SnapshotLocation
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawSnapshotLocation -> RIO env SnapshotLocation
completeSnapshotLocation (RawSnapshotLocation -> RIO env SnapshotLocation)
-> RIO env RawSnapshotLocation -> RIO env SnapshotLocation
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SnapName -> RIO env RawSnapshotLocation
forall env.
HasPantryConfig env =>
SnapName -> RIO env RawSnapshotLocation
snapshotLocation SnapName
syn

traverseConcurrently_
  :: (Foldable f, HasPantryConfig env)
  => (a -> RIO env ()) -- ^ action to perform
  -> f a -- ^ input values
  -> RIO env ()
traverseConcurrently_ :: (a -> RIO env ()) -> f a -> RIO env ()
traverseConcurrently_ a -> RIO env ()
f f a
t0 = do
  Int
cnt <- Getting Int env Int -> RIO env Int
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting Int env Int -> RIO env Int)
-> Getting Int env Int -> RIO env Int
forall a b. (a -> b) -> a -> b
$ (PantryConfig -> Const Int PantryConfig) -> env -> Const Int env
forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigL((PantryConfig -> Const Int PantryConfig) -> env -> Const Int env)
-> ((Int -> Const Int Int)
    -> PantryConfig -> Const Int PantryConfig)
-> Getting Int env Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PantryConfig -> Int) -> SimpleGetter PantryConfig Int
forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig -> Int
pcConnectionCount
  Int -> (a -> RIO env ()) -> f a -> RIO env ()
forall (m :: * -> *) (f :: * -> *) a.
(MonadUnliftIO m, Foldable f) =>
Int -> (a -> m ()) -> f a -> m ()
traverseConcurrentlyWith_ Int
cnt a -> RIO env ()
f f a
t0

traverseConcurrentlyWith_
  :: (MonadUnliftIO m, Foldable f)
  => Int -- ^ concurrent workers
  -> (a -> m ()) -- ^ action to perform
  -> f a -- ^ input values
  -> m ()
traverseConcurrentlyWith_ :: Int -> (a -> m ()) -> f a -> m ()
traverseConcurrentlyWith_ Int
count a -> m ()
f f a
t0 = do
  TVar [a]
queue <- [a] -> m (TVar [a])
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO ([a] -> m (TVar [a])) -> [a] -> m (TVar [a])
forall a b. (a -> b) -> a -> b
$ f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f a
t0

  Int -> m () -> m ()
forall (m :: * -> *) a.
(Applicative m, MonadUnliftIO m) =>
Int -> m a -> m ()
replicateConcurrently_ Int
count (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    (m () -> m ()) -> m ()
forall a. (a -> a) -> a
fix ((m () -> m ()) -> m ()) -> (m () -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \m ()
loop -> m (m ()) -> m ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m ()) -> m ()) -> m (m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ STM (m ()) -> m (m ())
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (m ()) -> m (m ())) -> STM (m ()) -> m (m ())
forall a b. (a -> b) -> a -> b
$ do
      [a]
toProcess <- TVar [a] -> STM [a]
forall a. TVar a -> STM a
readTVar TVar [a]
queue
      case [a]
toProcess of
        [] -> m () -> STM (m ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
        (a
x:[a]
rest) -> do
          TVar [a] -> [a] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [a]
queue [a]
rest
          m () -> STM (m ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m () -> STM (m ())) -> m () -> STM (m ())
forall a b. (a -> b) -> a -> b
$ do
            a -> m ()
f a
x
            m ()
loop

-- | Parse a 'RawSnapshot' (all layers) from a 'RawSnapshotLocation'.
--
-- @since 0.1.0.0
loadSnapshotRaw
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => RawSnapshotLocation
  -> RIO env RawSnapshot
loadSnapshotRaw :: RawSnapshotLocation -> RIO env RawSnapshot
loadSnapshotRaw RawSnapshotLocation
loc = do
  Either WantedCompiler (RawSnapshotLayer, CompletedSL)
eres <- RawSnapshotLocation
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawSnapshotLocation
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
loadRawSnapshotLayer RawSnapshotLocation
loc
  case Either WantedCompiler (RawSnapshotLayer, CompletedSL)
eres of
    Left WantedCompiler
wc ->
      RawSnapshot -> RIO env RawSnapshot
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshot :: WantedCompiler
-> Map PackageName RawSnapshotPackage
-> Set PackageName
-> RawSnapshot
RawSnapshot
        { rsCompiler :: WantedCompiler
rsCompiler = WantedCompiler
wc
        , rsPackages :: Map PackageName RawSnapshotPackage
rsPackages = Map PackageName RawSnapshotPackage
forall a. Monoid a => a
mempty
        , rsDrop :: Set PackageName
rsDrop = Set PackageName
forall a. Monoid a => a
mempty
        }
    Right (RawSnapshotLayer
rsl, CompletedSL
_) -> do
      RawSnapshot
snap0 <- RawSnapshotLocation -> RIO env RawSnapshot
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawSnapshotLocation -> RIO env RawSnapshot
loadSnapshotRaw (RawSnapshotLocation -> RIO env RawSnapshot)
-> RawSnapshotLocation -> RIO env RawSnapshot
forall a b. (a -> b) -> a -> b
$ RawSnapshotLayer -> RawSnapshotLocation
rslParent RawSnapshotLayer
rsl
      (Map PackageName RawSnapshotPackage
packages, AddPackagesConfig
unused) <-
        Utf8Builder
-> [RawPackageLocationImmutable]
-> AddPackagesConfig
-> Map PackageName RawSnapshotPackage
-> RIO env (Map PackageName RawSnapshotPackage, AddPackagesConfig)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Utf8Builder
-> [RawPackageLocationImmutable]
-> AddPackagesConfig
-> Map PackageName RawSnapshotPackage
-> RIO env (Map PackageName RawSnapshotPackage, AddPackagesConfig)
addPackagesToSnapshot
          (RawSnapshotLocation -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
loc)
          (RawSnapshotLayer -> [RawPackageLocationImmutable]
rslLocations RawSnapshotLayer
rsl)
          AddPackagesConfig :: Set PackageName
-> Map PackageName (Map FlagName Bool)
-> Map PackageName Bool
-> Map PackageName [Text]
-> AddPackagesConfig
AddPackagesConfig
            { apcDrop :: Set PackageName
apcDrop = RawSnapshotLayer -> Set PackageName
rslDropPackages RawSnapshotLayer
rsl
            , apcFlags :: Map PackageName (Map FlagName Bool)
apcFlags = RawSnapshotLayer -> Map PackageName (Map FlagName Bool)
rslFlags RawSnapshotLayer
rsl
            , apcHiddens :: Map PackageName Bool
apcHiddens = RawSnapshotLayer -> Map PackageName Bool
rslHidden RawSnapshotLayer
rsl
            , apcGhcOptions :: Map PackageName [Text]
apcGhcOptions = RawSnapshotLayer -> Map PackageName [Text]
rslGhcOptions RawSnapshotLayer
rsl
            }
          (RawSnapshot -> Map PackageName RawSnapshotPackage
rsPackages RawSnapshot
snap0)
      Utf8Builder -> AddPackagesConfig -> RIO env ()
forall env.
HasLogFunc env =>
Utf8Builder -> AddPackagesConfig -> RIO env ()
warnUnusedAddPackagesConfig (RawSnapshotLocation -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
loc) AddPackagesConfig
unused
      RawSnapshot -> RIO env RawSnapshot
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshot :: WantedCompiler
-> Map PackageName RawSnapshotPackage
-> Set PackageName
-> RawSnapshot
RawSnapshot
        { rsCompiler :: WantedCompiler
rsCompiler = WantedCompiler -> Maybe WantedCompiler -> WantedCompiler
forall a. a -> Maybe a -> a
fromMaybe (RawSnapshot -> WantedCompiler
rsCompiler RawSnapshot
snap0) (RawSnapshotLayer -> Maybe WantedCompiler
rslCompiler RawSnapshotLayer
rsl)
        , rsPackages :: Map PackageName RawSnapshotPackage
rsPackages = Map PackageName RawSnapshotPackage
packages
        , rsDrop :: Set PackageName
rsDrop = AddPackagesConfig -> Set PackageName
apcDrop AddPackagesConfig
unused
        }

-- | Parse a 'RawSnapshot' (all layers) from a 'SnapshotLocation'.
--
-- @since 0.1.0.0
loadSnapshot
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => SnapshotLocation
  -> RIO env RawSnapshot
loadSnapshot :: SnapshotLocation -> RIO env RawSnapshot
loadSnapshot SnapshotLocation
loc = do
  Either WantedCompiler RawSnapshotLayer
eres <- SnapshotLocation
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall env.
(HasPantryConfig env, HasLogFunc env) =>
SnapshotLocation
-> RIO env (Either WantedCompiler RawSnapshotLayer)
loadSnapshotLayer SnapshotLocation
loc
  case Either WantedCompiler RawSnapshotLayer
eres of
    Left WantedCompiler
wc ->
      RawSnapshot -> RIO env RawSnapshot
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshot :: WantedCompiler
-> Map PackageName RawSnapshotPackage
-> Set PackageName
-> RawSnapshot
RawSnapshot
        { rsCompiler :: WantedCompiler
rsCompiler = WantedCompiler
wc
        , rsPackages :: Map PackageName RawSnapshotPackage
rsPackages = Map PackageName RawSnapshotPackage
forall a. Monoid a => a
mempty
        , rsDrop :: Set PackageName
rsDrop = Set PackageName
forall a. Monoid a => a
mempty
        }
    Right RawSnapshotLayer
rsl -> do
      RawSnapshot
snap0 <- RawSnapshotLocation -> RIO env RawSnapshot
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawSnapshotLocation -> RIO env RawSnapshot
loadSnapshotRaw (RawSnapshotLocation -> RIO env RawSnapshot)
-> RawSnapshotLocation -> RIO env RawSnapshot
forall a b. (a -> b) -> a -> b
$ RawSnapshotLayer -> RawSnapshotLocation
rslParent RawSnapshotLayer
rsl
      (Map PackageName RawSnapshotPackage
packages, AddPackagesConfig
unused) <-
        Utf8Builder
-> [RawPackageLocationImmutable]
-> AddPackagesConfig
-> Map PackageName RawSnapshotPackage
-> RIO env (Map PackageName RawSnapshotPackage, AddPackagesConfig)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Utf8Builder
-> [RawPackageLocationImmutable]
-> AddPackagesConfig
-> Map PackageName RawSnapshotPackage
-> RIO env (Map PackageName RawSnapshotPackage, AddPackagesConfig)
addPackagesToSnapshot
          (SnapshotLocation -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display SnapshotLocation
loc)
          (RawSnapshotLayer -> [RawPackageLocationImmutable]
rslLocations RawSnapshotLayer
rsl)
          AddPackagesConfig :: Set PackageName
-> Map PackageName (Map FlagName Bool)
-> Map PackageName Bool
-> Map PackageName [Text]
-> AddPackagesConfig
AddPackagesConfig
            { apcDrop :: Set PackageName
apcDrop = RawSnapshotLayer -> Set PackageName
rslDropPackages RawSnapshotLayer
rsl
            , apcFlags :: Map PackageName (Map FlagName Bool)
apcFlags = RawSnapshotLayer -> Map PackageName (Map FlagName Bool)
rslFlags RawSnapshotLayer
rsl
            , apcHiddens :: Map PackageName Bool
apcHiddens = RawSnapshotLayer -> Map PackageName Bool
rslHidden RawSnapshotLayer
rsl
            , apcGhcOptions :: Map PackageName [Text]
apcGhcOptions = RawSnapshotLayer -> Map PackageName [Text]
rslGhcOptions RawSnapshotLayer
rsl
            }
          (RawSnapshot -> Map PackageName RawSnapshotPackage
rsPackages RawSnapshot
snap0)
      Utf8Builder -> AddPackagesConfig -> RIO env ()
forall env.
HasLogFunc env =>
Utf8Builder -> AddPackagesConfig -> RIO env ()
warnUnusedAddPackagesConfig (SnapshotLocation -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display SnapshotLocation
loc) AddPackagesConfig
unused
      RawSnapshot -> RIO env RawSnapshot
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshot :: WantedCompiler
-> Map PackageName RawSnapshotPackage
-> Set PackageName
-> RawSnapshot
RawSnapshot
        { rsCompiler :: WantedCompiler
rsCompiler = WantedCompiler -> Maybe WantedCompiler -> WantedCompiler
forall a. a -> Maybe a -> a
fromMaybe (RawSnapshot -> WantedCompiler
rsCompiler RawSnapshot
snap0) (RawSnapshotLayer -> Maybe WantedCompiler
rslCompiler RawSnapshotLayer
rsl)
        , rsPackages :: Map PackageName RawSnapshotPackage
rsPackages = Map PackageName RawSnapshotPackage
packages
        , rsDrop :: Set PackageName
rsDrop = AddPackagesConfig -> Set PackageName
apcDrop AddPackagesConfig
unused
        }

-- | A completed package location, including the original raw and completed information.
--
-- @since 0.1.0.0
data CompletedPLI = CompletedPLI !RawPackageLocationImmutable !PackageLocationImmutable

-- | A completed snapshot location, including the original raw and completed information.
--
-- @since 0.1.0.0
data CompletedSL = CompletedSL !RawSnapshotLocation !SnapshotLocation

-- | Parse a 'Snapshot' (all layers) from a 'SnapshotLocation' noting
-- any incomplete package locations
--
-- @since 0.1.0.0
loadAndCompleteSnapshot
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => SnapshotLocation
  -> Map RawSnapshotLocation SnapshotLocation -- ^ Cached snapshot locations from lock file
  -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached locations from lock file
  -> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshot :: SnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshot SnapshotLocation
loc Map RawSnapshotLocation SnapshotLocation
cachedSL Map RawPackageLocationImmutable PackageLocationImmutable
cachedPL =
  RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshotRaw (SnapshotLocation -> RawSnapshotLocation
toRawSL SnapshotLocation
loc) Map RawSnapshotLocation SnapshotLocation
cachedSL Map RawPackageLocationImmutable PackageLocationImmutable
cachedPL

-- | Parse a 'Snapshot' (all layers) from a 'RawSnapshotLocation' completing
-- any incomplete package locations
--
-- @since 0.1.0.0
loadAndCompleteSnapshotRaw
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => RawSnapshotLocation
  -> Map RawSnapshotLocation SnapshotLocation -- ^ Cached snapshot locations from lock file
  -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached locations from lock file
  -> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshotRaw :: RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshotRaw RawSnapshotLocation
rawLoc Map RawSnapshotLocation SnapshotLocation
cacheSL Map RawPackageLocationImmutable PackageLocationImmutable
cachePL = do
  Either WantedCompiler (RawSnapshotLayer, CompletedSL)
eres <- case RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Maybe SnapshotLocation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RawSnapshotLocation
rawLoc Map RawSnapshotLocation SnapshotLocation
cacheSL of
    Just SnapshotLocation
loc -> (RawSnapshotLayer -> (RawSnapshotLayer, CompletedSL))
-> Either WantedCompiler RawSnapshotLayer
-> Either WantedCompiler (RawSnapshotLayer, CompletedSL)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right (\RawSnapshotLayer
rsl -> (RawSnapshotLayer
rsl, (RawSnapshotLocation -> SnapshotLocation -> CompletedSL
CompletedSL RawSnapshotLocation
rawLoc SnapshotLocation
loc))) (Either WantedCompiler RawSnapshotLayer
 -> Either WantedCompiler (RawSnapshotLayer, CompletedSL))
-> RIO env (Either WantedCompiler RawSnapshotLayer)
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SnapshotLocation
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall env.
(HasPantryConfig env, HasLogFunc env) =>
SnapshotLocation
-> RIO env (Either WantedCompiler RawSnapshotLayer)
loadSnapshotLayer SnapshotLocation
loc
    Maybe SnapshotLocation
Nothing -> RawSnapshotLocation
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawSnapshotLocation
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
loadRawSnapshotLayer RawSnapshotLocation
rawLoc
  case Either WantedCompiler (RawSnapshotLayer, CompletedSL)
eres of
    Left WantedCompiler
wc ->
      let snapshot :: Snapshot
snapshot = Snapshot :: WantedCompiler
-> Map PackageName SnapshotPackage -> Set PackageName -> Snapshot
Snapshot
            { snapshotCompiler :: WantedCompiler
snapshotCompiler = WantedCompiler
wc
            , snapshotPackages :: Map PackageName SnapshotPackage
snapshotPackages = Map PackageName SnapshotPackage
forall a. Monoid a => a
mempty
            , snapshotDrop :: Set PackageName
snapshotDrop = Set PackageName
forall a. Monoid a => a
mempty
            }
      in (Snapshot, [CompletedSL], [CompletedPLI])
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Snapshot
snapshot, [RawSnapshotLocation -> SnapshotLocation -> CompletedSL
CompletedSL (WantedCompiler -> RawSnapshotLocation
RSLCompiler WantedCompiler
wc) (WantedCompiler -> SnapshotLocation
SLCompiler WantedCompiler
wc)], [])
    Right (RawSnapshotLayer
rsl, CompletedSL
sloc) -> do
      (Snapshot
snap0, [CompletedSL]
slocs, [CompletedPLI]
completed0) <- RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshotRaw (RawSnapshotLayer -> RawSnapshotLocation
rslParent RawSnapshotLayer
rsl) Map RawSnapshotLocation SnapshotLocation
cacheSL Map RawPackageLocationImmutable PackageLocationImmutable
cachePL
      Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (FilePath -> Utf8Builder) -> FilePath -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ RawSnapshotLayer -> FilePath
forall a. Show a => a -> FilePath
show RawSnapshotLayer
rsl
      (Map PackageName SnapshotPackage
packages, [CompletedPLI]
completed, AddPackagesConfig
unused) <-
        RawSnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> [RawPackageLocationImmutable]
-> AddPackagesConfig
-> Map PackageName SnapshotPackage
-> RIO
     env
     (Map PackageName SnapshotPackage, [CompletedPLI],
      AddPackagesConfig)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawSnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> [RawPackageLocationImmutable]
-> AddPackagesConfig
-> Map PackageName SnapshotPackage
-> RIO
     env
     (Map PackageName SnapshotPackage, [CompletedPLI],
      AddPackagesConfig)
addAndCompletePackagesToSnapshot
          RawSnapshotLocation
rawLoc
          Map RawPackageLocationImmutable PackageLocationImmutable
cachePL
          (RawSnapshotLayer -> [RawPackageLocationImmutable]
rslLocations RawSnapshotLayer
rsl)
          AddPackagesConfig :: Set PackageName
-> Map PackageName (Map FlagName Bool)
-> Map PackageName Bool
-> Map PackageName [Text]
-> AddPackagesConfig
AddPackagesConfig
            { apcDrop :: Set PackageName
apcDrop = RawSnapshotLayer -> Set PackageName
rslDropPackages RawSnapshotLayer
rsl
            , apcFlags :: Map PackageName (Map FlagName Bool)
apcFlags = RawSnapshotLayer -> Map PackageName (Map FlagName Bool)
rslFlags RawSnapshotLayer
rsl
            , apcHiddens :: Map PackageName Bool
apcHiddens = RawSnapshotLayer -> Map PackageName Bool
rslHidden RawSnapshotLayer
rsl
            , apcGhcOptions :: Map PackageName [Text]
apcGhcOptions = RawSnapshotLayer -> Map PackageName [Text]
rslGhcOptions RawSnapshotLayer
rsl
            }
          (Snapshot -> Map PackageName SnapshotPackage
snapshotPackages Snapshot
snap0)
      Utf8Builder -> AddPackagesConfig -> RIO env ()
forall env.
HasLogFunc env =>
Utf8Builder -> AddPackagesConfig -> RIO env ()
warnUnusedAddPackagesConfig (RawSnapshotLocation -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
rawLoc) AddPackagesConfig
unused
      let snapshot :: Snapshot
snapshot = Snapshot :: WantedCompiler
-> Map PackageName SnapshotPackage -> Set PackageName -> Snapshot
Snapshot
            { snapshotCompiler :: WantedCompiler
snapshotCompiler = WantedCompiler -> Maybe WantedCompiler -> WantedCompiler
forall a. a -> Maybe a -> a
fromMaybe (Snapshot -> WantedCompiler
snapshotCompiler Snapshot
snap0) (RawSnapshotLayer -> Maybe WantedCompiler
rslCompiler RawSnapshotLayer
rsl)
            , snapshotPackages :: Map PackageName SnapshotPackage
snapshotPackages = Map PackageName SnapshotPackage
packages
            , snapshotDrop :: Set PackageName
snapshotDrop = AddPackagesConfig -> Set PackageName
apcDrop AddPackagesConfig
unused
            }
      (Snapshot, [CompletedSL], [CompletedPLI])
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
forall (m :: * -> *) a. Monad m => a -> m a
return (Snapshot
snapshot, CompletedSL
sloc CompletedSL -> [CompletedSL] -> [CompletedSL]
forall a. a -> [a] -> [a]
: [CompletedSL]
slocs,[CompletedPLI]
completed0 [CompletedPLI] -> [CompletedPLI] -> [CompletedPLI]
forall a. [a] -> [a] -> [a]
++ [CompletedPLI]
completed)

data SingleOrNot a
  = Single !a
  | Multiple !a !a !([a] -> [a])
instance Semigroup (SingleOrNot a) where
  Single a
a <> :: SingleOrNot a -> SingleOrNot a -> SingleOrNot a
<> Single a
b = a -> a -> ([a] -> [a]) -> SingleOrNot a
forall a. a -> a -> ([a] -> [a]) -> SingleOrNot a
Multiple a
a a
b [a] -> [a]
forall a. a -> a
id
  Single a
a <> Multiple a
b a
c [a] -> [a]
d = a -> a -> ([a] -> [a]) -> SingleOrNot a
forall a. a -> a -> ([a] -> [a]) -> SingleOrNot a
Multiple a
a a
b ((a
ca -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
d)
  Multiple a
a a
b [a] -> [a]
c <> Single a
d = a -> a -> ([a] -> [a]) -> SingleOrNot a
forall a. a -> a -> ([a] -> [a]) -> SingleOrNot a
Multiple a
a a
b ([a] -> [a]
c ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
da -> [a] -> [a]
forall a. a -> [a] -> [a]
:))
  Multiple a
a a
b [a] -> [a]
c <> Multiple a
d a
e [a] -> [a]
f =
    a -> a -> ([a] -> [a]) -> SingleOrNot a
forall a. a -> a -> ([a] -> [a]) -> SingleOrNot a
Multiple a
a a
b ([a] -> [a]
c ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
da -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
ea -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
f)

sonToEither :: (k, SingleOrNot a) -> Either (k, a) (k, [a])
sonToEither :: (k, SingleOrNot a) -> Either (k, a) (k, [a])
sonToEither (k
k, Single a
a) = (k, a) -> Either (k, a) (k, [a])
forall a b. a -> Either a b
Left (k
k, a
a)
sonToEither (k
k, Multiple a
a a
b [a] -> [a]
c) = (k, [a]) -> Either (k, a) (k, [a])
forall a b. b -> Either a b
Right (k
k, (a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a
b a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
c []))

-- | Package settings to be passed to 'addPackagesToSnapshot'.
--
-- @since 0.1.0.0
data AddPackagesConfig = AddPackagesConfig
  { AddPackagesConfig -> Set PackageName
apcDrop :: !(Set PackageName)
  , AddPackagesConfig -> Map PackageName (Map FlagName Bool)
apcFlags :: !(Map PackageName (Map FlagName Bool))
  , AddPackagesConfig -> Map PackageName Bool
apcHiddens :: !(Map PackageName Bool)
  , AddPackagesConfig -> Map PackageName [Text]
apcGhcOptions :: !(Map PackageName [Text])
  }

-- | Does not warn about drops, those are allowed in order to ignore global
-- packages.
warnUnusedAddPackagesConfig
  :: HasLogFunc env
  => Utf8Builder -- ^ source
  -> AddPackagesConfig
  -> RIO env ()
warnUnusedAddPackagesConfig :: Utf8Builder -> AddPackagesConfig -> RIO env ()
warnUnusedAddPackagesConfig Utf8Builder
source (AddPackagesConfig Set PackageName
_drops Map PackageName (Map FlagName Bool)
flags Map PackageName Bool
hiddens Map PackageName [Text]
options) = do
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Utf8Builder] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Utf8Builder]
ls) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
    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
"Some warnings discovered when adding packages to snapshot (" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
source Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
")"
    (Utf8Builder -> RIO env ()) -> [Utf8Builder] -> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn [Utf8Builder]
ls
  where
    ls :: [Utf8Builder]
ls = [[Utf8Builder]] -> [Utf8Builder]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Utf8Builder]
flags', [Utf8Builder]
hiddens', [Utf8Builder]
options']

    flags' :: [Utf8Builder]
flags' =
      (PackageName -> Utf8Builder) -> [PackageName] -> [Utf8Builder]
forall a b. (a -> b) -> [a] -> [b]
map
        (\PackageName
pn ->
          Utf8Builder
"Setting flags for non-existent package: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
          FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (PackageName -> FilePath
packageNameString PackageName
pn))
        (Map PackageName (Map FlagName Bool) -> [PackageName]
forall k a. Map k a -> [k]
Map.keys Map PackageName (Map FlagName Bool)
flags)

    hiddens' :: [Utf8Builder]
hiddens' =
      (PackageName -> Utf8Builder) -> [PackageName] -> [Utf8Builder]
forall a b. (a -> b) -> [a] -> [b]
map
        (\PackageName
pn ->
          Utf8Builder
"Hiding non-existent package: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
          FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (PackageName -> FilePath
packageNameString PackageName
pn))
        (Map PackageName Bool -> [PackageName]
forall k a. Map k a -> [k]
Map.keys Map PackageName Bool
hiddens)

    options' :: [Utf8Builder]
options' =
      (PackageName -> Utf8Builder) -> [PackageName] -> [Utf8Builder]
forall a b. (a -> b) -> [a] -> [b]
map
        (\PackageName
pn ->
          Utf8Builder
"Setting options for non-existent package: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
          FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (PackageName -> FilePath
packageNameString PackageName
pn))
        (Map PackageName [Text] -> [PackageName]
forall k a. Map k a -> [k]
Map.keys Map PackageName [Text]
options)

-- | Add more packages to a snapshot
--
-- Note that any settings on a parent flag which is being replaced will be
-- ignored. For example, if package @foo@ is in the parent and has flag @bar@
-- set, and @foo@ also appears in new packages, then @bar@ will no longer be
-- set.
--
-- Returns any of the 'AddPackagesConfig' values not used.
--
-- @since 0.1.0.0
addPackagesToSnapshot
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => Utf8Builder
  -- ^ Text description of where these new packages are coming from, for error
  -- messages only
  -> [RawPackageLocationImmutable] -- ^ new packages
  -> AddPackagesConfig
  -> Map PackageName RawSnapshotPackage -- ^ packages from parent
  -> RIO env (Map PackageName RawSnapshotPackage, AddPackagesConfig)
addPackagesToSnapshot :: Utf8Builder
-> [RawPackageLocationImmutable]
-> AddPackagesConfig
-> Map PackageName RawSnapshotPackage
-> RIO env (Map PackageName RawSnapshotPackage, AddPackagesConfig)
addPackagesToSnapshot Utf8Builder
source [RawPackageLocationImmutable]
newPackages (AddPackagesConfig Set PackageName
drops Map PackageName (Map FlagName Bool)
flags Map PackageName Bool
hiddens Map PackageName [Text]
options) Map PackageName RawSnapshotPackage
old = do
  [(PackageName, RawSnapshotPackage)]
new' <- [RawPackageLocationImmutable]
-> (RawPackageLocationImmutable
    -> RIO env (PackageName, RawSnapshotPackage))
-> RIO env [(PackageName, RawSnapshotPackage)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [RawPackageLocationImmutable]
newPackages ((RawPackageLocationImmutable
  -> RIO env (PackageName, RawSnapshotPackage))
 -> RIO env [(PackageName, RawSnapshotPackage)])
-> (RawPackageLocationImmutable
    -> RIO env (PackageName, RawSnapshotPackage))
-> RIO env [(PackageName, RawSnapshotPackage)]
forall a b. (a -> b) -> a -> b
$ \RawPackageLocationImmutable
loc -> do
    PackageName
name <- RawPackageLocationImmutable -> RIO env PackageName
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env PackageName
getPackageLocationName RawPackageLocationImmutable
loc
    (PackageName, RawSnapshotPackage)
-> RIO env (PackageName, RawSnapshotPackage)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageName
name, RawSnapshotPackage :: RawPackageLocationImmutable
-> Map FlagName Bool -> Bool -> [Text] -> RawSnapshotPackage
RawSnapshotPackage
      { rspLocation :: RawPackageLocationImmutable
rspLocation = RawPackageLocationImmutable
loc
      , rspFlags :: Map FlagName Bool
rspFlags = Map FlagName Bool
-> PackageName
-> Map PackageName (Map FlagName Bool)
-> Map FlagName Bool
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Map FlagName Bool
forall a. Monoid a => a
mempty PackageName
name Map PackageName (Map FlagName Bool)
flags
      , rspHidden :: Bool
rspHidden = Bool -> PackageName -> Map PackageName Bool -> Bool
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Bool
False PackageName
name Map PackageName Bool
hiddens
      , rspGhcOptions :: [Text]
rspGhcOptions = [Text] -> PackageName -> Map PackageName [Text] -> [Text]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] PackageName
name Map PackageName [Text]
options
      })
  let ([(PackageName, RawSnapshotPackage)]
newSingles, [(PackageName, [RawSnapshotPackage])]
newMultiples)
        = [Either
   (PackageName, RawSnapshotPackage)
   (PackageName, [RawSnapshotPackage])]
-> ([(PackageName, RawSnapshotPackage)],
    [(PackageName, [RawSnapshotPackage])])
forall a b. [Either a b] -> ([a], [b])
partitionEithers
        ([Either
    (PackageName, RawSnapshotPackage)
    (PackageName, [RawSnapshotPackage])]
 -> ([(PackageName, RawSnapshotPackage)],
     [(PackageName, [RawSnapshotPackage])]))
-> [Either
      (PackageName, RawSnapshotPackage)
      (PackageName, [RawSnapshotPackage])]
-> ([(PackageName, RawSnapshotPackage)],
    [(PackageName, [RawSnapshotPackage])])
forall a b. (a -> b) -> a -> b
$ ((PackageName, SingleOrNot RawSnapshotPackage)
 -> Either
      (PackageName, RawSnapshotPackage)
      (PackageName, [RawSnapshotPackage]))
-> [(PackageName, SingleOrNot RawSnapshotPackage)]
-> [Either
      (PackageName, RawSnapshotPackage)
      (PackageName, [RawSnapshotPackage])]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, SingleOrNot RawSnapshotPackage)
-> Either
     (PackageName, RawSnapshotPackage)
     (PackageName, [RawSnapshotPackage])
forall k a. (k, SingleOrNot a) -> Either (k, a) (k, [a])
sonToEither
        ([(PackageName, SingleOrNot RawSnapshotPackage)]
 -> [Either
       (PackageName, RawSnapshotPackage)
       (PackageName, [RawSnapshotPackage])])
-> [(PackageName, SingleOrNot RawSnapshotPackage)]
-> [Either
      (PackageName, RawSnapshotPackage)
      (PackageName, [RawSnapshotPackage])]
forall a b. (a -> b) -> a -> b
$ Map PackageName (SingleOrNot RawSnapshotPackage)
-> [(PackageName, SingleOrNot RawSnapshotPackage)]
forall k a. Map k a -> [(k, a)]
Map.toList
        (Map PackageName (SingleOrNot RawSnapshotPackage)
 -> [(PackageName, SingleOrNot RawSnapshotPackage)])
-> Map PackageName (SingleOrNot RawSnapshotPackage)
-> [(PackageName, SingleOrNot RawSnapshotPackage)]
forall a b. (a -> b) -> a -> b
$ (SingleOrNot RawSnapshotPackage
 -> SingleOrNot RawSnapshotPackage
 -> SingleOrNot RawSnapshotPackage)
-> [(PackageName, SingleOrNot RawSnapshotPackage)]
-> Map PackageName (SingleOrNot RawSnapshotPackage)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith SingleOrNot RawSnapshotPackage
-> SingleOrNot RawSnapshotPackage -> SingleOrNot RawSnapshotPackage
forall a. Semigroup a => a -> a -> a
(<>)
        ([(PackageName, SingleOrNot RawSnapshotPackage)]
 -> Map PackageName (SingleOrNot RawSnapshotPackage))
-> [(PackageName, SingleOrNot RawSnapshotPackage)]
-> Map PackageName (SingleOrNot RawSnapshotPackage)
forall a b. (a -> b) -> a -> b
$ ((PackageName, RawSnapshotPackage)
 -> (PackageName, SingleOrNot RawSnapshotPackage))
-> [(PackageName, RawSnapshotPackage)]
-> [(PackageName, SingleOrNot RawSnapshotPackage)]
forall a b. (a -> b) -> [a] -> [b]
map ((RawSnapshotPackage -> SingleOrNot RawSnapshotPackage)
-> (PackageName, RawSnapshotPackage)
-> (PackageName, SingleOrNot RawSnapshotPackage)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second RawSnapshotPackage -> SingleOrNot RawSnapshotPackage
forall a. a -> SingleOrNot a
Single) [(PackageName, RawSnapshotPackage)]
new'
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(PackageName, [RawSnapshotPackage])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(PackageName, [RawSnapshotPackage])] -> Bool)
-> [(PackageName, [RawSnapshotPackage])] -> Bool
forall a b. (a -> b) -> a -> b
$ [(PackageName, [RawSnapshotPackage])]
newMultiples) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ PantryException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env ()) -> PantryException -> RIO env ()
forall a b. (a -> b) -> a -> b
$
    Utf8Builder
-> [(PackageName, [RawPackageLocationImmutable])]
-> PantryException
DuplicatePackageNames Utf8Builder
source ([(PackageName, [RawPackageLocationImmutable])] -> PantryException)
-> [(PackageName, [RawPackageLocationImmutable])]
-> PantryException
forall a b. (a -> b) -> a -> b
$ ((PackageName, [RawSnapshotPackage])
 -> (PackageName, [RawPackageLocationImmutable]))
-> [(PackageName, [RawSnapshotPackage])]
-> [(PackageName, [RawPackageLocationImmutable])]
forall a b. (a -> b) -> [a] -> [b]
map (([RawSnapshotPackage] -> [RawPackageLocationImmutable])
-> (PackageName, [RawSnapshotPackage])
-> (PackageName, [RawPackageLocationImmutable])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((RawSnapshotPackage -> RawPackageLocationImmutable)
-> [RawSnapshotPackage] -> [RawPackageLocationImmutable]
forall a b. (a -> b) -> [a] -> [b]
map RawSnapshotPackage -> RawPackageLocationImmutable
rspLocation)) [(PackageName, [RawSnapshotPackage])]
newMultiples
  let new :: Map PackageName RawSnapshotPackage
new = [(PackageName, RawSnapshotPackage)]
-> Map PackageName RawSnapshotPackage
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PackageName, RawSnapshotPackage)]
newSingles
      allPackages0 :: Map PackageName RawSnapshotPackage
allPackages0 = Map PackageName RawSnapshotPackage
new Map PackageName RawSnapshotPackage
-> Map PackageName RawSnapshotPackage
-> Map PackageName RawSnapshotPackage
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` (Map PackageName RawSnapshotPackage
old Map PackageName RawSnapshotPackage
-> Map PackageName () -> Map PackageName RawSnapshotPackage
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` (PackageName -> ()) -> Set PackageName -> Map PackageName ()
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (() -> PackageName -> ()
forall a b. a -> b -> a
const ()) Set PackageName
drops)
      allPackages :: Map PackageName RawSnapshotPackage
allPackages = ((PackageName -> RawSnapshotPackage -> RawSnapshotPackage)
 -> Map PackageName RawSnapshotPackage
 -> Map PackageName RawSnapshotPackage)
-> Map PackageName RawSnapshotPackage
-> (PackageName -> RawSnapshotPackage -> RawSnapshotPackage)
-> Map PackageName RawSnapshotPackage
forall a b c. (a -> b -> c) -> b -> a -> c
flip (PackageName -> RawSnapshotPackage -> RawSnapshotPackage)
-> Map PackageName RawSnapshotPackage
-> Map PackageName RawSnapshotPackage
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey Map PackageName RawSnapshotPackage
allPackages0 ((PackageName -> RawSnapshotPackage -> RawSnapshotPackage)
 -> Map PackageName RawSnapshotPackage)
-> (PackageName -> RawSnapshotPackage -> RawSnapshotPackage)
-> Map PackageName RawSnapshotPackage
forall a b. (a -> b) -> a -> b
$ \PackageName
name RawSnapshotPackage
rsp ->
        RawSnapshotPackage
rsp
          { rspFlags :: Map FlagName Bool
rspFlags = Map FlagName Bool
-> PackageName
-> Map PackageName (Map FlagName Bool)
-> Map FlagName Bool
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (RawSnapshotPackage -> Map FlagName Bool
rspFlags RawSnapshotPackage
rsp) PackageName
name Map PackageName (Map FlagName Bool)
flags
          , rspHidden :: Bool
rspHidden = Bool -> PackageName -> Map PackageName Bool -> Bool
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (RawSnapshotPackage -> Bool
rspHidden RawSnapshotPackage
rsp) PackageName
name Map PackageName Bool
hiddens
          , rspGhcOptions :: [Text]
rspGhcOptions = [Text] -> PackageName -> Map PackageName [Text] -> [Text]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (RawSnapshotPackage -> [Text]
rspGhcOptions RawSnapshotPackage
rsp) PackageName
name Map PackageName [Text]
options
          }

      unused :: AddPackagesConfig
unused = Set PackageName
-> Map PackageName (Map FlagName Bool)
-> Map PackageName Bool
-> Map PackageName [Text]
-> AddPackagesConfig
AddPackagesConfig
        (Set PackageName
drops Set PackageName -> Set PackageName -> Set PackageName
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Map PackageName RawSnapshotPackage -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet Map PackageName RawSnapshotPackage
old)
        (Map PackageName (Map FlagName Bool)
flags Map PackageName (Map FlagName Bool)
-> Map PackageName RawSnapshotPackage
-> Map PackageName (Map FlagName Bool)
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` Map PackageName RawSnapshotPackage
allPackages)
        (Map PackageName Bool
hiddens Map PackageName Bool
-> Map PackageName RawSnapshotPackage -> Map PackageName Bool
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` Map PackageName RawSnapshotPackage
allPackages)
        (Map PackageName [Text]
options Map PackageName [Text]
-> Map PackageName RawSnapshotPackage -> Map PackageName [Text]
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` Map PackageName RawSnapshotPackage
allPackages)

  (Map PackageName RawSnapshotPackage, AddPackagesConfig)
-> RIO env (Map PackageName RawSnapshotPackage, AddPackagesConfig)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PackageName RawSnapshotPackage
allPackages, AddPackagesConfig
unused)

cachedSnapshotCompletePackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => Map RawPackageLocationImmutable PackageLocationImmutable
  -> RawPackageLocationImmutable
  -> RIO env (Maybe PackageLocationImmutable)
cachedSnapshotCompletePackageLocation :: Map RawPackageLocationImmutable PackageLocationImmutable
-> RawPackageLocationImmutable
-> RIO env (Maybe PackageLocationImmutable)
cachedSnapshotCompletePackageLocation Map RawPackageLocationImmutable PackageLocationImmutable
cachePackages RawPackageLocationImmutable
rpli = do
  let xs :: Maybe PackageLocationImmutable
xs = RawPackageLocationImmutable
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> Maybe PackageLocationImmutable
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RawPackageLocationImmutable
rpli Map RawPackageLocationImmutable PackageLocationImmutable
cachePackages
  case Maybe PackageLocationImmutable
xs of
    Maybe PackageLocationImmutable
Nothing -> do
      CompletePackageLocation
cpl <- RawPackageLocationImmutable -> RIO env CompletePackageLocation
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env CompletePackageLocation
completePackageLocation RawPackageLocationImmutable
rpli
      Maybe PackageLocationImmutable
-> RIO env (Maybe PackageLocationImmutable)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe PackageLocationImmutable
 -> RIO env (Maybe PackageLocationImmutable))
-> Maybe PackageLocationImmutable
-> RIO env (Maybe PackageLocationImmutable)
forall a b. (a -> b) -> a -> b
$ if CompletePackageLocation -> Bool
cplHasCabalFile CompletePackageLocation
cpl then PackageLocationImmutable -> Maybe PackageLocationImmutable
forall a. a -> Maybe a
Just (CompletePackageLocation -> PackageLocationImmutable
cplComplete CompletePackageLocation
cpl) else Maybe PackageLocationImmutable
forall a. Maybe a
Nothing
    Just PackageLocationImmutable
x -> Maybe PackageLocationImmutable
-> RIO env (Maybe PackageLocationImmutable)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe PackageLocationImmutable
 -> RIO env (Maybe PackageLocationImmutable))
-> Maybe PackageLocationImmutable
-> RIO env (Maybe PackageLocationImmutable)
forall a b. (a -> b) -> a -> b
$ PackageLocationImmutable -> Maybe PackageLocationImmutable
forall a. a -> Maybe a
Just PackageLocationImmutable
x

-- | Add more packages to a snapshot completing their locations if needed
--
-- Note that any settings on a parent flag which is being replaced will be
-- ignored. For example, if package @foo@ is in the parent and has flag @bar@
-- set, and @foo@ also appears in new packages, then @bar@ will no longer be
-- set.
--
-- Returns any of the 'AddPackagesConfig' values not used and also all
-- non-trivial package location completions.
--
-- @since 0.1.0.0
addAndCompletePackagesToSnapshot
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => RawSnapshotLocation
  -- ^ Text description of where these new packages are coming from, for error
  -- messages only
  -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached data from snapshot lock file
  -> [RawPackageLocationImmutable] -- ^ new packages
  -> AddPackagesConfig
  -> Map PackageName SnapshotPackage -- ^ packages from parent
  -> RIO env (Map PackageName SnapshotPackage, [CompletedPLI], AddPackagesConfig)
addAndCompletePackagesToSnapshot :: RawSnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> [RawPackageLocationImmutable]
-> AddPackagesConfig
-> Map PackageName SnapshotPackage
-> RIO
     env
     (Map PackageName SnapshotPackage, [CompletedPLI],
      AddPackagesConfig)
addAndCompletePackagesToSnapshot RawSnapshotLocation
loc Map RawPackageLocationImmutable PackageLocationImmutable
cachedPL [RawPackageLocationImmutable]
newPackages (AddPackagesConfig Set PackageName
drops Map PackageName (Map FlagName Bool)
flags Map PackageName Bool
hiddens Map PackageName [Text]
options) Map PackageName SnapshotPackage
old = do
  let source :: Utf8Builder
source = RawSnapshotLocation -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
loc
      addPackage :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
                 => ([(PackageName, SnapshotPackage)],[CompletedPLI])
                 -> RawPackageLocationImmutable
                 -> RIO env ([(PackageName, SnapshotPackage)], [CompletedPLI])
      addPackage :: ([(PackageName, SnapshotPackage)], [CompletedPLI])
-> RawPackageLocationImmutable
-> RIO env ([(PackageName, SnapshotPackage)], [CompletedPLI])
addPackage ([(PackageName, SnapshotPackage)]
ps, [CompletedPLI]
completed) RawPackageLocationImmutable
rawLoc = do
        Maybe PackageLocationImmutable
mcomplLoc <- Map RawPackageLocationImmutable PackageLocationImmutable
-> RawPackageLocationImmutable
-> RIO env (Maybe PackageLocationImmutable)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Map RawPackageLocationImmutable PackageLocationImmutable
-> RawPackageLocationImmutable
-> RIO env (Maybe PackageLocationImmutable)
cachedSnapshotCompletePackageLocation Map RawPackageLocationImmutable PackageLocationImmutable
cachedPL RawPackageLocationImmutable
rawLoc
        case Maybe PackageLocationImmutable
mcomplLoc of
          Maybe PackageLocationImmutable
Nothing -> do
            RawPackageLocationImmutable -> RIO env ()
forall env.
HasLogFunc env =>
RawPackageLocationImmutable -> RIO env ()
warnMissingCabalFile RawPackageLocationImmutable
rawLoc
            ([(PackageName, SnapshotPackage)], [CompletedPLI])
-> RIO env ([(PackageName, SnapshotPackage)], [CompletedPLI])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(PackageName, SnapshotPackage)]
ps, [CompletedPLI]
completed)
          Just PackageLocationImmutable
complLoc -> do
            let PackageIdentifier PackageName
name Version
_ = PackageLocationImmutable -> PackageIdentifier
packageLocationIdent PackageLocationImmutable
complLoc
                p :: (PackageName, SnapshotPackage)
p = (PackageName
name, SnapshotPackage :: PackageLocationImmutable
-> Map FlagName Bool -> Bool -> [Text] -> SnapshotPackage
SnapshotPackage
                  { spLocation :: PackageLocationImmutable
spLocation = PackageLocationImmutable
complLoc
                  , spFlags :: Map FlagName Bool
spFlags = Map FlagName Bool
-> PackageName
-> Map PackageName (Map FlagName Bool)
-> Map FlagName Bool
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Map FlagName Bool
forall a. Monoid a => a
mempty PackageName
name Map PackageName (Map FlagName Bool)
flags
                  , spHidden :: Bool
spHidden = Bool -> PackageName -> Map PackageName Bool -> Bool
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Bool
False PackageName
name Map PackageName Bool
hiddens
                  , spGhcOptions :: [Text]
spGhcOptions = [Text] -> PackageName -> Map PackageName [Text] -> [Text]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] PackageName
name Map PackageName [Text]
options
                  })
                completed' :: [CompletedPLI]
completed' = if PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI PackageLocationImmutable
complLoc RawPackageLocationImmutable -> RawPackageLocationImmutable -> Bool
forall a. Eq a => a -> a -> Bool
== RawPackageLocationImmutable
rawLoc
                             then [CompletedPLI]
completed
                             else RawPackageLocationImmutable
-> PackageLocationImmutable -> CompletedPLI
CompletedPLI RawPackageLocationImmutable
rawLoc PackageLocationImmutable
complLocCompletedPLI -> [CompletedPLI] -> [CompletedPLI]
forall a. a -> [a] -> [a]
:[CompletedPLI]
completed
            ([(PackageName, SnapshotPackage)], [CompletedPLI])
-> RIO env ([(PackageName, SnapshotPackage)], [CompletedPLI])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((PackageName, SnapshotPackage)
p(PackageName, SnapshotPackage)
-> [(PackageName, SnapshotPackage)]
-> [(PackageName, SnapshotPackage)]
forall a. a -> [a] -> [a]
:[(PackageName, SnapshotPackage)]
ps, [CompletedPLI]
completed')
  ([(PackageName, SnapshotPackage)]
revNew, [CompletedPLI]
revCompleted) <- (([(PackageName, SnapshotPackage)], [CompletedPLI])
 -> RawPackageLocationImmutable
 -> RIO env ([(PackageName, SnapshotPackage)], [CompletedPLI]))
-> ([(PackageName, SnapshotPackage)], [CompletedPLI])
-> [RawPackageLocationImmutable]
-> RIO env ([(PackageName, SnapshotPackage)], [CompletedPLI])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ([(PackageName, SnapshotPackage)], [CompletedPLI])
-> RawPackageLocationImmutable
-> RIO env ([(PackageName, SnapshotPackage)], [CompletedPLI])
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
([(PackageName, SnapshotPackage)], [CompletedPLI])
-> RawPackageLocationImmutable
-> RIO env ([(PackageName, SnapshotPackage)], [CompletedPLI])
addPackage ([], []) [RawPackageLocationImmutable]
newPackages
  let ([(PackageName, SnapshotPackage)]
newSingles, [(PackageName, [SnapshotPackage])]
newMultiples)
        = [Either
   (PackageName, SnapshotPackage) (PackageName, [SnapshotPackage])]
-> ([(PackageName, SnapshotPackage)],
    [(PackageName, [SnapshotPackage])])
forall a b. [Either a b] -> ([a], [b])
partitionEithers
        ([Either
    (PackageName, SnapshotPackage) (PackageName, [SnapshotPackage])]
 -> ([(PackageName, SnapshotPackage)],
     [(PackageName, [SnapshotPackage])]))
-> [Either
      (PackageName, SnapshotPackage) (PackageName, [SnapshotPackage])]
-> ([(PackageName, SnapshotPackage)],
    [(PackageName, [SnapshotPackage])])
forall a b. (a -> b) -> a -> b
$ ((PackageName, SingleOrNot SnapshotPackage)
 -> Either
      (PackageName, SnapshotPackage) (PackageName, [SnapshotPackage]))
-> [(PackageName, SingleOrNot SnapshotPackage)]
-> [Either
      (PackageName, SnapshotPackage) (PackageName, [SnapshotPackage])]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, SingleOrNot SnapshotPackage)
-> Either
     (PackageName, SnapshotPackage) (PackageName, [SnapshotPackage])
forall k a. (k, SingleOrNot a) -> Either (k, a) (k, [a])
sonToEither
        ([(PackageName, SingleOrNot SnapshotPackage)]
 -> [Either
       (PackageName, SnapshotPackage) (PackageName, [SnapshotPackage])])
-> [(PackageName, SingleOrNot SnapshotPackage)]
-> [Either
      (PackageName, SnapshotPackage) (PackageName, [SnapshotPackage])]
forall a b. (a -> b) -> a -> b
$ Map PackageName (SingleOrNot SnapshotPackage)
-> [(PackageName, SingleOrNot SnapshotPackage)]
forall k a. Map k a -> [(k, a)]
Map.toList
        (Map PackageName (SingleOrNot SnapshotPackage)
 -> [(PackageName, SingleOrNot SnapshotPackage)])
-> Map PackageName (SingleOrNot SnapshotPackage)
-> [(PackageName, SingleOrNot SnapshotPackage)]
forall a b. (a -> b) -> a -> b
$ (SingleOrNot SnapshotPackage
 -> SingleOrNot SnapshotPackage -> SingleOrNot SnapshotPackage)
-> [(PackageName, SingleOrNot SnapshotPackage)]
-> Map PackageName (SingleOrNot SnapshotPackage)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith SingleOrNot SnapshotPackage
-> SingleOrNot SnapshotPackage -> SingleOrNot SnapshotPackage
forall a. Semigroup a => a -> a -> a
(<>)
        ([(PackageName, SingleOrNot SnapshotPackage)]
 -> Map PackageName (SingleOrNot SnapshotPackage))
-> [(PackageName, SingleOrNot SnapshotPackage)]
-> Map PackageName (SingleOrNot SnapshotPackage)
forall a b. (a -> b) -> a -> b
$ ((PackageName, SnapshotPackage)
 -> (PackageName, SingleOrNot SnapshotPackage))
-> [(PackageName, SnapshotPackage)]
-> [(PackageName, SingleOrNot SnapshotPackage)]
forall a b. (a -> b) -> [a] -> [b]
map ((SnapshotPackage -> SingleOrNot SnapshotPackage)
-> (PackageName, SnapshotPackage)
-> (PackageName, SingleOrNot SnapshotPackage)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second SnapshotPackage -> SingleOrNot SnapshotPackage
forall a. a -> SingleOrNot a
Single) ([(PackageName, SnapshotPackage)]
-> [(PackageName, SnapshotPackage)]
forall a. [a] -> [a]
reverse [(PackageName, SnapshotPackage)]
revNew)
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(PackageName, [SnapshotPackage])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(PackageName, [SnapshotPackage])] -> Bool)
-> [(PackageName, [SnapshotPackage])] -> Bool
forall a b. (a -> b) -> a -> b
$ [(PackageName, [SnapshotPackage])]
newMultiples) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ PantryException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env ()) -> PantryException -> RIO env ()
forall a b. (a -> b) -> a -> b
$
    Utf8Builder
-> [(PackageName, [RawPackageLocationImmutable])]
-> PantryException
DuplicatePackageNames Utf8Builder
source ([(PackageName, [RawPackageLocationImmutable])] -> PantryException)
-> [(PackageName, [RawPackageLocationImmutable])]
-> PantryException
forall a b. (a -> b) -> a -> b
$ ((PackageName, [SnapshotPackage])
 -> (PackageName, [RawPackageLocationImmutable]))
-> [(PackageName, [SnapshotPackage])]
-> [(PackageName, [RawPackageLocationImmutable])]
forall a b. (a -> b) -> [a] -> [b]
map (([SnapshotPackage] -> [RawPackageLocationImmutable])
-> (PackageName, [SnapshotPackage])
-> (PackageName, [RawPackageLocationImmutable])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((SnapshotPackage -> RawPackageLocationImmutable)
-> [SnapshotPackage] -> [RawPackageLocationImmutable]
forall a b. (a -> b) -> [a] -> [b]
map (PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI (PackageLocationImmutable -> RawPackageLocationImmutable)
-> (SnapshotPackage -> PackageLocationImmutable)
-> SnapshotPackage
-> RawPackageLocationImmutable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapshotPackage -> PackageLocationImmutable
spLocation))) [(PackageName, [SnapshotPackage])]
newMultiples
  let new :: Map PackageName SnapshotPackage
new = [(PackageName, SnapshotPackage)] -> Map PackageName SnapshotPackage
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PackageName, SnapshotPackage)]
newSingles
      allPackages0 :: Map PackageName SnapshotPackage
allPackages0 = Map PackageName SnapshotPackage
new Map PackageName SnapshotPackage
-> Map PackageName SnapshotPackage
-> Map PackageName SnapshotPackage
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` (Map PackageName SnapshotPackage
old Map PackageName SnapshotPackage
-> Map PackageName () -> Map PackageName SnapshotPackage
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` (PackageName -> ()) -> Set PackageName -> Map PackageName ()
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (() -> PackageName -> ()
forall a b. a -> b -> a
const ()) Set PackageName
drops)
      allPackages :: Map PackageName SnapshotPackage
allPackages = ((PackageName -> SnapshotPackage -> SnapshotPackage)
 -> Map PackageName SnapshotPackage
 -> Map PackageName SnapshotPackage)
-> Map PackageName SnapshotPackage
-> (PackageName -> SnapshotPackage -> SnapshotPackage)
-> Map PackageName SnapshotPackage
forall a b c. (a -> b -> c) -> b -> a -> c
flip (PackageName -> SnapshotPackage -> SnapshotPackage)
-> Map PackageName SnapshotPackage
-> Map PackageName SnapshotPackage
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey Map PackageName SnapshotPackage
allPackages0 ((PackageName -> SnapshotPackage -> SnapshotPackage)
 -> Map PackageName SnapshotPackage)
-> (PackageName -> SnapshotPackage -> SnapshotPackage)
-> Map PackageName SnapshotPackage
forall a b. (a -> b) -> a -> b
$ \PackageName
name SnapshotPackage
sp ->
        SnapshotPackage
sp
          { spFlags :: Map FlagName Bool
spFlags = Map FlagName Bool
-> PackageName
-> Map PackageName (Map FlagName Bool)
-> Map FlagName Bool
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (SnapshotPackage -> Map FlagName Bool
spFlags SnapshotPackage
sp) PackageName
name Map PackageName (Map FlagName Bool)
flags
          , spHidden :: Bool
spHidden = Bool -> PackageName -> Map PackageName Bool -> Bool
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (SnapshotPackage -> Bool
spHidden SnapshotPackage
sp) PackageName
name Map PackageName Bool
hiddens
          , spGhcOptions :: [Text]
spGhcOptions = [Text] -> PackageName -> Map PackageName [Text] -> [Text]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (SnapshotPackage -> [Text]
spGhcOptions SnapshotPackage
sp) PackageName
name Map PackageName [Text]
options
          }

      unused :: AddPackagesConfig
unused = Set PackageName
-> Map PackageName (Map FlagName Bool)
-> Map PackageName Bool
-> Map PackageName [Text]
-> AddPackagesConfig
AddPackagesConfig
        (Set PackageName
drops Set PackageName -> Set PackageName -> Set PackageName
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Map PackageName SnapshotPackage -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet Map PackageName SnapshotPackage
old)
        (Map PackageName (Map FlagName Bool)
flags Map PackageName (Map FlagName Bool)
-> Map PackageName SnapshotPackage
-> Map PackageName (Map FlagName Bool)
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` Map PackageName SnapshotPackage
allPackages)
        (Map PackageName Bool
hiddens Map PackageName Bool
-> Map PackageName SnapshotPackage -> Map PackageName Bool
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` Map PackageName SnapshotPackage
allPackages)
        (Map PackageName [Text]
options Map PackageName [Text]
-> Map PackageName SnapshotPackage -> Map PackageName [Text]
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` Map PackageName SnapshotPackage
allPackages)

  (Map PackageName SnapshotPackage, [CompletedPLI],
 AddPackagesConfig)
-> RIO
     env
     (Map PackageName SnapshotPackage, [CompletedPLI],
      AddPackagesConfig)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PackageName SnapshotPackage
allPackages, [CompletedPLI] -> [CompletedPLI]
forall a. [a] -> [a]
reverse [CompletedPLI]
revCompleted, AddPackagesConfig
unused)

-- | Parse a 'SnapshotLayer' value from a 'SnapshotLocation'.
--
-- Returns a 'Left' value if provided an 'SLCompiler'
-- constructor. Otherwise, returns a 'Right' value providing both the
-- 'Snapshot' and a hash of the input configuration file.
--
-- @since 0.1.0.0
loadRawSnapshotLayer
  :: (HasPantryConfig env, HasLogFunc env)
  => RawSnapshotLocation
  -> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
loadRawSnapshotLayer :: RawSnapshotLocation
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
loadRawSnapshotLayer (RSLCompiler WantedCompiler
compiler) = Either WantedCompiler (RawSnapshotLayer, CompletedSL)
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either WantedCompiler (RawSnapshotLayer, CompletedSL)
 -> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL)))
-> Either WantedCompiler (RawSnapshotLayer, CompletedSL)
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall a b. (a -> b) -> a -> b
$ WantedCompiler
-> Either WantedCompiler (RawSnapshotLayer, CompletedSL)
forall a b. a -> Either a b
Left WantedCompiler
compiler
loadRawSnapshotLayer rsl :: RawSnapshotLocation
rsl@(RSLUrl Text
url Maybe BlobKey
blob) =
  (SomeException
 -> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL)))
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny (PantryException
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException
 -> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL)))
-> (SomeException -> PantryException)
-> SomeException
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSnapshotLocation -> SomeException -> PantryException
InvalidSnapshot RawSnapshotLocation
rsl) (RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
 -> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL)))
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall a b. (a -> b) -> a -> b
$ do
    ByteString
bs <- Text -> Maybe BlobKey -> RIO env ByteString
forall env.
(HasPantryConfig env, HasLogFunc env) =>
Text -> Maybe BlobKey -> RIO env ByteString
loadFromURL Text
url Maybe BlobKey
blob
    Value
value <- ByteString -> RIO env Value
forall (m :: * -> *) a.
(MonadThrow m, FromJSON a) =>
ByteString -> m a
Yaml.decodeThrow ByteString
bs
    RawSnapshotLayer
snapshot <- RawSnapshotLocation
-> Value -> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
forall env.
HasLogFunc env =>
RawSnapshotLocation
-> Value -> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
warningsParserHelperRaw RawSnapshotLocation
rsl Value
value Maybe (Path Abs Dir)
forall a. Maybe a
Nothing
    Either WantedCompiler (RawSnapshotLayer, CompletedSL)
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either WantedCompiler (RawSnapshotLayer, CompletedSL)
 -> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL)))
-> Either WantedCompiler (RawSnapshotLayer, CompletedSL)
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall a b. (a -> b) -> a -> b
$ (RawSnapshotLayer, CompletedSL)
-> Either WantedCompiler (RawSnapshotLayer, CompletedSL)
forall a b. b -> Either a b
Right (RawSnapshotLayer
snapshot, (RawSnapshotLocation -> SnapshotLocation -> CompletedSL
CompletedSL RawSnapshotLocation
rsl (Text -> BlobKey -> SnapshotLocation
SLUrl Text
url (ByteString -> BlobKey
bsToBlobKey ByteString
bs))))
loadRawSnapshotLayer rsl :: RawSnapshotLocation
rsl@(RSLFilePath ResolvedPath File
fp) =
  (SomeException
 -> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL)))
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny (PantryException
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException
 -> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL)))
-> (SomeException -> PantryException)
-> SomeException
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSnapshotLocation -> SomeException -> PantryException
InvalidSnapshot RawSnapshotLocation
rsl) (RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
 -> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL)))
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall a b. (a -> b) -> a -> b
$ do
    Value
value <- FilePath -> RIO env Value
forall (m :: * -> *) a. (MonadIO m, FromJSON a) => FilePath -> m a
Yaml.decodeFileThrow (FilePath -> RIO env Value) -> FilePath -> RIO env Value
forall a b. (a -> b) -> a -> b
$ Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath (Path Abs File -> FilePath) -> Path Abs File -> FilePath
forall a b. (a -> b) -> a -> b
$ ResolvedPath File -> Path Abs File
forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath File
fp
    RawSnapshotLayer
snapshot <- RawSnapshotLocation
-> Value -> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
forall env.
HasLogFunc env =>
RawSnapshotLocation
-> Value -> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
warningsParserHelperRaw RawSnapshotLocation
rsl Value
value (Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer)
-> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> Maybe (Path Abs Dir)
forall a. a -> Maybe a
Just (Path Abs Dir -> Maybe (Path Abs Dir))
-> Path Abs Dir -> Maybe (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent (Path Abs File -> Path Abs Dir) -> Path Abs File -> Path Abs Dir
forall a b. (a -> b) -> a -> b
$ ResolvedPath File -> Path Abs File
forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath File
fp
    Either WantedCompiler (RawSnapshotLayer, CompletedSL)
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either WantedCompiler (RawSnapshotLayer, CompletedSL)
 -> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL)))
-> Either WantedCompiler (RawSnapshotLayer, CompletedSL)
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall a b. (a -> b) -> a -> b
$ (RawSnapshotLayer, CompletedSL)
-> Either WantedCompiler (RawSnapshotLayer, CompletedSL)
forall a b. b -> Either a b
Right (RawSnapshotLayer
snapshot, RawSnapshotLocation -> SnapshotLocation -> CompletedSL
CompletedSL RawSnapshotLocation
rsl (ResolvedPath File -> SnapshotLocation
SLFilePath ResolvedPath File
fp))
loadRawSnapshotLayer rsl :: RawSnapshotLocation
rsl@(RSLSynonym SnapName
syn) = do
  RawSnapshotLocation
loc <- SnapName -> RIO env RawSnapshotLocation
forall env.
HasPantryConfig env =>
SnapName -> RIO env RawSnapshotLocation
snapshotLocation SnapName
syn
  Either WantedCompiler (RawSnapshotLayer, CompletedSL)
comp <- RawSnapshotLocation
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawSnapshotLocation
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
loadRawSnapshotLayer RawSnapshotLocation
loc
  Either WantedCompiler (RawSnapshotLayer, CompletedSL)
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either WantedCompiler (RawSnapshotLayer, CompletedSL)
 -> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL)))
-> Either WantedCompiler (RawSnapshotLayer, CompletedSL)
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall a b. (a -> b) -> a -> b
$ case Either WantedCompiler (RawSnapshotLayer, CompletedSL)
comp of
    Left WantedCompiler
wc -> WantedCompiler
-> Either WantedCompiler (RawSnapshotLayer, CompletedSL)
forall a b. a -> Either a b
Left WantedCompiler
wc
    Right (RawSnapshotLayer
l, CompletedSL RawSnapshotLocation
_ SnapshotLocation
n) -> (RawSnapshotLayer, CompletedSL)
-> Either WantedCompiler (RawSnapshotLayer, CompletedSL)
forall a b. b -> Either a b
Right (RawSnapshotLayer
l, RawSnapshotLocation -> SnapshotLocation -> CompletedSL
CompletedSL RawSnapshotLocation
rsl SnapshotLocation
n)

-- | Parse a 'SnapshotLayer' value from a 'SnapshotLocation'.
--
-- Returns a 'Left' value if provided an 'SLCompiler'
-- constructor. Otherwise, returns a 'Right' value providing both the
-- 'Snapshot' and a hash of the input configuration file.
--
-- @since 0.1.0.0
loadSnapshotLayer
  :: (HasPantryConfig env, HasLogFunc env)
  => SnapshotLocation
  -> RIO env (Either WantedCompiler RawSnapshotLayer)
loadSnapshotLayer :: SnapshotLocation
-> RIO env (Either WantedCompiler RawSnapshotLayer)
loadSnapshotLayer (SLCompiler WantedCompiler
compiler) = Either WantedCompiler RawSnapshotLayer
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either WantedCompiler RawSnapshotLayer
 -> RIO env (Either WantedCompiler RawSnapshotLayer))
-> Either WantedCompiler RawSnapshotLayer
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall a b. (a -> b) -> a -> b
$ WantedCompiler -> Either WantedCompiler RawSnapshotLayer
forall a b. a -> Either a b
Left WantedCompiler
compiler
loadSnapshotLayer sl :: SnapshotLocation
sl@(SLUrl Text
url BlobKey
blob) =
  (SomeException -> RIO env (Either WantedCompiler RawSnapshotLayer))
-> RIO env (Either WantedCompiler RawSnapshotLayer)
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny (PantryException -> RIO env (Either WantedCompiler RawSnapshotLayer)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException
 -> RIO env (Either WantedCompiler RawSnapshotLayer))
-> (SomeException -> PantryException)
-> SomeException
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSnapshotLocation -> SomeException -> PantryException
InvalidSnapshot (SnapshotLocation -> RawSnapshotLocation
toRawSL SnapshotLocation
sl)) (RIO env (Either WantedCompiler RawSnapshotLayer)
 -> RIO env (Either WantedCompiler RawSnapshotLayer))
-> RIO env (Either WantedCompiler RawSnapshotLayer)
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall a b. (a -> b) -> a -> b
$ do
    ByteString
bs <- Text -> Maybe BlobKey -> RIO env ByteString
forall env.
(HasPantryConfig env, HasLogFunc env) =>
Text -> Maybe BlobKey -> RIO env ByteString
loadFromURL Text
url (BlobKey -> Maybe BlobKey
forall a. a -> Maybe a
Just BlobKey
blob)
    Value
value <- ByteString -> RIO env Value
forall (m :: * -> *) a.
(MonadThrow m, FromJSON a) =>
ByteString -> m a
Yaml.decodeThrow ByteString
bs
    RawSnapshotLayer
snapshot <- SnapshotLocation
-> Value -> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
forall env.
HasLogFunc env =>
SnapshotLocation
-> Value -> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
warningsParserHelper SnapshotLocation
sl Value
value Maybe (Path Abs Dir)
forall a. Maybe a
Nothing
    Either WantedCompiler RawSnapshotLayer
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either WantedCompiler RawSnapshotLayer
 -> RIO env (Either WantedCompiler RawSnapshotLayer))
-> Either WantedCompiler RawSnapshotLayer
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall a b. (a -> b) -> a -> b
$ RawSnapshotLayer -> Either WantedCompiler RawSnapshotLayer
forall a b. b -> Either a b
Right RawSnapshotLayer
snapshot
loadSnapshotLayer sl :: SnapshotLocation
sl@(SLFilePath ResolvedPath File
fp) =
  (SomeException -> RIO env (Either WantedCompiler RawSnapshotLayer))
-> RIO env (Either WantedCompiler RawSnapshotLayer)
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny (PantryException -> RIO env (Either WantedCompiler RawSnapshotLayer)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException
 -> RIO env (Either WantedCompiler RawSnapshotLayer))
-> (SomeException -> PantryException)
-> SomeException
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSnapshotLocation -> SomeException -> PantryException
InvalidSnapshot (SnapshotLocation -> RawSnapshotLocation
toRawSL SnapshotLocation
sl)) (RIO env (Either WantedCompiler RawSnapshotLayer)
 -> RIO env (Either WantedCompiler RawSnapshotLayer))
-> RIO env (Either WantedCompiler RawSnapshotLayer)
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall a b. (a -> b) -> a -> b
$ do
    Value
value <- FilePath -> RIO env Value
forall (m :: * -> *) a. (MonadIO m, FromJSON a) => FilePath -> m a
Yaml.decodeFileThrow (FilePath -> RIO env Value) -> FilePath -> RIO env Value
forall a b. (a -> b) -> a -> b
$ Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath (Path Abs File -> FilePath) -> Path Abs File -> FilePath
forall a b. (a -> b) -> a -> b
$ ResolvedPath File -> Path Abs File
forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath File
fp
    RawSnapshotLayer
snapshot <- SnapshotLocation
-> Value -> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
forall env.
HasLogFunc env =>
SnapshotLocation
-> Value -> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
warningsParserHelper SnapshotLocation
sl Value
value (Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer)
-> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> Maybe (Path Abs Dir)
forall a. a -> Maybe a
Just (Path Abs Dir -> Maybe (Path Abs Dir))
-> Path Abs Dir -> Maybe (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent (Path Abs File -> Path Abs Dir) -> Path Abs File -> Path Abs Dir
forall a b. (a -> b) -> a -> b
$ ResolvedPath File -> Path Abs File
forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath File
fp
    Either WantedCompiler RawSnapshotLayer
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either WantedCompiler RawSnapshotLayer
 -> RIO env (Either WantedCompiler RawSnapshotLayer))
-> Either WantedCompiler RawSnapshotLayer
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall a b. (a -> b) -> a -> b
$ RawSnapshotLayer -> Either WantedCompiler RawSnapshotLayer
forall a b. b -> Either a b
Right RawSnapshotLayer
snapshot

loadFromURL
  :: (HasPantryConfig env, HasLogFunc env)
  => Text -- ^ url
  -> Maybe BlobKey
  -> RIO env ByteString
loadFromURL :: Text -> Maybe BlobKey -> RIO env ByteString
loadFromURL Text
url Maybe BlobKey
Nothing = do
  Maybe ByteString
mcached <- ReaderT SqlBackend (RIO env) (Maybe ByteString)
-> RIO env (Maybe ByteString)
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) (Maybe ByteString)
 -> RIO env (Maybe ByteString))
-> ReaderT SqlBackend (RIO env) (Maybe ByteString)
-> RIO env (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ Text -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
forall env. Text -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
loadURLBlob Text
url
  case Maybe ByteString
mcached of
    Just ByteString
bs -> ByteString -> RIO env ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
    Maybe ByteString
Nothing -> Text -> Maybe BlobKey -> RIO env ByteString
forall env.
(HasPantryConfig env, HasLogFunc env) =>
Text -> Maybe BlobKey -> RIO env ByteString
loadWithCheck Text
url Maybe BlobKey
forall a. Maybe a
Nothing
loadFromURL Text
url (Just BlobKey
bkey) = do
  Maybe ByteString
mcached <- ReaderT SqlBackend (RIO env) (Maybe ByteString)
-> RIO env (Maybe ByteString)
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) (Maybe ByteString)
 -> RIO env (Maybe ByteString))
-> ReaderT SqlBackend (RIO env) (Maybe ByteString)
-> RIO env (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ BlobKey -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
forall env.
HasLogFunc env =>
BlobKey -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
loadBlob BlobKey
bkey
  case Maybe ByteString
mcached of
    Just ByteString
bs -> do
      Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Loaded snapshot from Pantry database."
      ByteString -> RIO env ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
    Maybe ByteString
Nothing -> Text -> BlobKey -> RIO env ByteString
forall env.
(HasPantryConfig env, HasLogFunc env) =>
Text -> BlobKey -> RIO env ByteString
loadUrlViaCasaOrWithCheck Text
url BlobKey
bkey

loadUrlViaCasaOrWithCheck
  :: (HasPantryConfig env, HasLogFunc env)
  => Text -- ^ url
  -> BlobKey
  -> RIO env ByteString
loadUrlViaCasaOrWithCheck :: Text -> BlobKey -> RIO env ByteString
loadUrlViaCasaOrWithCheck Text
url BlobKey
blobKey = do
  Maybe ByteString
mblobFromCasa <- BlobKey -> RIO env (Maybe ByteString)
forall env.
(HasPantryConfig env, HasLogFunc env) =>
BlobKey -> RIO env (Maybe ByteString)
casaLookupKey BlobKey
blobKey
  case Maybe ByteString
mblobFromCasa of
    Just ByteString
blob -> do
      Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug
        (Utf8Builder
"Loaded snapshot from Casa (" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> BlobKey -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display BlobKey
blobKey Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
") for URL: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
         Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
url)
      ByteString -> RIO env ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
blob
    Maybe ByteString
Nothing -> Text -> Maybe BlobKey -> RIO env ByteString
forall env.
(HasPantryConfig env, HasLogFunc env) =>
Text -> Maybe BlobKey -> RIO env ByteString
loadWithCheck Text
url (BlobKey -> Maybe BlobKey
forall a. a -> Maybe a
Just BlobKey
blobKey)

loadWithCheck
  :: (HasPantryConfig env, HasLogFunc env)
  => Text -- ^ url
  -> Maybe BlobKey
  -> RIO env ByteString
loadWithCheck :: Text -> Maybe BlobKey -> RIO env ByteString
loadWithCheck Text
url Maybe BlobKey
mblobkey = do
  let (Maybe SHA256
msha, Maybe FileSize
msize) =
        case Maybe BlobKey
mblobkey of
          Maybe BlobKey
Nothing -> (Maybe SHA256
forall a. Maybe a
Nothing, Maybe FileSize
forall a. Maybe a
Nothing)
          Just (BlobKey SHA256
sha FileSize
size) -> (SHA256 -> Maybe SHA256
forall a. a -> Maybe a
Just SHA256
sha, FileSize -> Maybe FileSize
forall a. a -> Maybe a
Just FileSize
size)
  (SHA256
_, FileSize
_, [ByteString]
bss) <- Text
-> Maybe SHA256
-> Maybe FileSize
-> ConduitT ByteString Void (RIO env) [ByteString]
-> RIO env (SHA256, FileSize, [ByteString])
forall (m :: * -> *) a.
MonadUnliftIO m =>
Text
-> Maybe SHA256
-> Maybe FileSize
-> ConduitT ByteString Void m a
-> m (SHA256, FileSize, a)
httpSinkChecked Text
url Maybe SHA256
msha Maybe FileSize
msize ConduitT ByteString Void (RIO env) [ByteString]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
sinkList
  let bs :: ByteString
bs = [ByteString] -> ByteString
B.concat [ByteString]
bss
  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
$ Text -> ByteString -> ReaderT SqlBackend (RIO env) ()
forall env. Text -> ByteString -> ReaderT SqlBackend (RIO env) ()
storeURLBlob Text
url ByteString
bs
  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Loaded snapshot from third party: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
url)
  ByteString -> RIO env ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs

warningsParserHelperRaw
  :: HasLogFunc env
  => RawSnapshotLocation
  -> Value
  -> Maybe (Path Abs Dir)
  -> RIO env RawSnapshotLayer
warningsParserHelperRaw :: RawSnapshotLocation
-> Value -> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
warningsParserHelperRaw RawSnapshotLocation
rsl Value
val Maybe (Path Abs Dir)
mdir =
  case (Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLayer)))
-> Value
-> Either FilePath (WithJSONWarnings (Unresolved RawSnapshotLayer))
forall a b. (a -> Parser b) -> a -> Either FilePath b
parseEither Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLayer))
forall a. FromJSON a => Value -> Parser a
Yaml.parseJSON Value
val of
    Left FilePath
e -> PantryException -> RIO env RawSnapshotLayer
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env RawSnapshotLayer)
-> PantryException -> RIO env RawSnapshotLayer
forall a b. (a -> b) -> a -> b
$ RawSnapshotLocation -> FilePath -> PantryException
Couldn'tParseSnapshot RawSnapshotLocation
rsl FilePath
e
    Right (WithJSONWarnings Unresolved RawSnapshotLayer
x [JSONWarning]
ws) -> do
      Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([JSONWarning] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [JSONWarning]
ws) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
        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
"Warnings when parsing snapshot " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> RawSnapshotLocation -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
rsl
        [JSONWarning] -> (JSONWarning -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [JSONWarning]
ws ((JSONWarning -> RIO env ()) -> RIO env ())
-> (JSONWarning -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ())
-> (JSONWarning -> Utf8Builder) -> JSONWarning -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSONWarning -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display
      Maybe (Path Abs Dir)
-> Unresolved RawSnapshotLayer -> RIO env RawSnapshotLayer
forall (m :: * -> *) a.
MonadIO m =>
Maybe (Path Abs Dir) -> Unresolved a -> m a
resolvePaths Maybe (Path Abs Dir)
mdir Unresolved RawSnapshotLayer
x

warningsParserHelper
  :: HasLogFunc env
  => SnapshotLocation
  -> Value
  -> Maybe (Path Abs Dir)
  -> RIO env RawSnapshotLayer
warningsParserHelper :: SnapshotLocation
-> Value -> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
warningsParserHelper SnapshotLocation
sl Value
val Maybe (Path Abs Dir)
mdir =
  case (Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLayer)))
-> Value
-> Either FilePath (WithJSONWarnings (Unresolved RawSnapshotLayer))
forall a b. (a -> Parser b) -> a -> Either FilePath b
parseEither Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLayer))
forall a. FromJSON a => Value -> Parser a
Yaml.parseJSON Value
val of
    Left FilePath
e -> PantryException -> RIO env RawSnapshotLayer
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env RawSnapshotLayer)
-> PantryException -> RIO env RawSnapshotLayer
forall a b. (a -> b) -> a -> b
$ RawSnapshotLocation -> FilePath -> PantryException
Couldn'tParseSnapshot (SnapshotLocation -> RawSnapshotLocation
toRawSL SnapshotLocation
sl) FilePath
e
    Right (WithJSONWarnings Unresolved RawSnapshotLayer
x [JSONWarning]
ws) -> do
      Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([JSONWarning] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [JSONWarning]
ws) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
        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
"Warnings when parsing snapshot " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> SnapshotLocation -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display SnapshotLocation
sl
        [JSONWarning] -> (JSONWarning -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [JSONWarning]
ws ((JSONWarning -> RIO env ()) -> RIO env ())
-> (JSONWarning -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ())
-> (JSONWarning -> Utf8Builder) -> JSONWarning -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSONWarning -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display
      Maybe (Path Abs Dir)
-> Unresolved RawSnapshotLayer -> RIO env RawSnapshotLayer
forall (m :: * -> *) a.
MonadIO m =>
Maybe (Path Abs Dir) -> Unresolved a -> m a
resolvePaths Maybe (Path Abs Dir)
mdir Unresolved RawSnapshotLayer
x

-- | Get the 'PackageName' of the package at the given location.
--
-- @since 0.1.0.0
getPackageLocationName
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => RawPackageLocationImmutable
  -> RIO env PackageName
getPackageLocationName :: RawPackageLocationImmutable -> RIO env PackageName
getPackageLocationName = (PackageIdentifier -> PackageName)
-> RIO env PackageIdentifier -> RIO env PackageName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageIdentifier -> PackageName
pkgName (RIO env PackageIdentifier -> RIO env PackageName)
-> (RawPackageLocationImmutable -> RIO env PackageIdentifier)
-> RawPackageLocationImmutable
-> RIO env PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawPackageLocationImmutable -> RIO env PackageIdentifier
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env PackageIdentifier
getRawPackageLocationIdent

-- | Get the 'PackageIdentifier' of the package at the given location.
--
-- @since 0.1.0.0
packageLocationIdent
  :: PackageLocationImmutable
  -> PackageIdentifier
packageLocationIdent :: PackageLocationImmutable -> PackageIdentifier
packageLocationIdent (PLIHackage PackageIdentifier
ident BlobKey
_ TreeKey
_) = PackageIdentifier
ident
packageLocationIdent (PLIRepo Repo
_ PackageMetadata
pm) = PackageMetadata -> PackageIdentifier
pmIdent PackageMetadata
pm
packageLocationIdent (PLIArchive Archive
_ PackageMetadata
pm) = PackageMetadata -> PackageIdentifier
pmIdent PackageMetadata
pm

-- | Get version of the package at the given location.
--
-- @since 0.1.0.0
packageLocationVersion
  :: PackageLocationImmutable
  -> Version
packageLocationVersion :: PackageLocationImmutable -> Version
packageLocationVersion (PLIHackage PackageIdentifier
pident BlobKey
_ TreeKey
_) = PackageIdentifier -> Version
pkgVersion PackageIdentifier
pident
packageLocationVersion (PLIRepo Repo
_ PackageMetadata
pm) = PackageIdentifier -> Version
pkgVersion (PackageMetadata -> PackageIdentifier
pmIdent PackageMetadata
pm)
packageLocationVersion (PLIArchive Archive
_ PackageMetadata
pm) = PackageIdentifier -> Version
pkgVersion (PackageMetadata -> PackageIdentifier
pmIdent PackageMetadata
pm)

-- | Get the 'PackageIdentifier' of the package at the given location.
--
-- @since 0.1.0.0
getRawPackageLocationIdent
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => RawPackageLocationImmutable
  -> RIO env PackageIdentifier
getRawPackageLocationIdent :: RawPackageLocationImmutable -> RIO env PackageIdentifier
getRawPackageLocationIdent (RPLIHackage (PackageIdentifierRevision PackageName
name Version
version CabalFileInfo
_) Maybe TreeKey
_) = PackageIdentifier -> RIO env PackageIdentifier
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageIdentifier -> RIO env PackageIdentifier)
-> PackageIdentifier -> RIO env PackageIdentifier
forall a b. (a -> b) -> a -> b
$ PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version
getRawPackageLocationIdent (RPLIRepo Repo
_ RawPackageMetadata { rpmName :: RawPackageMetadata -> Maybe PackageName
rpmName = Just PackageName
name, rpmVersion :: RawPackageMetadata -> Maybe Version
rpmVersion = Just Version
version }) = PackageIdentifier -> RIO env PackageIdentifier
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageIdentifier -> RIO env PackageIdentifier)
-> PackageIdentifier -> RIO env PackageIdentifier
forall a b. (a -> b) -> a -> b
$ PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version
getRawPackageLocationIdent (RPLIArchive RawArchive
_ RawPackageMetadata { rpmName :: RawPackageMetadata -> Maybe PackageName
rpmName = Just PackageName
name, rpmVersion :: RawPackageMetadata -> Maybe Version
rpmVersion = Just Version
version }) = PackageIdentifier -> RIO env PackageIdentifier
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageIdentifier -> RIO env PackageIdentifier)
-> PackageIdentifier -> RIO env PackageIdentifier
forall a b. (a -> b) -> a -> b
$ PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version
getRawPackageLocationIdent RawPackageLocationImmutable
rpli = Package -> PackageIdentifier
packageIdent (Package -> PackageIdentifier)
-> RIO env Package -> RIO env PackageIdentifier
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawPackageLocationImmutable -> RIO env Package
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env Package
loadPackageRaw RawPackageLocationImmutable
rpli

-- | Get the 'TreeKey' of the package at the given location.
--
-- @since 0.1.0.0
getRawPackageLocationTreeKey
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => RawPackageLocationImmutable
  -> RIO env TreeKey
getRawPackageLocationTreeKey :: RawPackageLocationImmutable -> RIO env TreeKey
getRawPackageLocationTreeKey RawPackageLocationImmutable
pl =
  case RawPackageLocationImmutable -> Maybe TreeKey
getRawTreeKey RawPackageLocationImmutable
pl of
    Just TreeKey
treeKey' -> TreeKey -> RIO env TreeKey
forall (f :: * -> *) a. Applicative f => a -> f a
pure TreeKey
treeKey'
    Maybe TreeKey
Nothing ->
      case RawPackageLocationImmutable
pl of
        RPLIHackage PackageIdentifierRevision
pir Maybe TreeKey
_ -> PackageIdentifierRevision -> RIO env TreeKey
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageIdentifierRevision -> RIO env TreeKey
getHackageTarballKey PackageIdentifierRevision
pir
        RPLIArchive RawArchive
archive RawPackageMetadata
pm -> RawPackageLocationImmutable
-> RawArchive -> RawPackageMetadata -> RIO env TreeKey
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> RawArchive -> RawPackageMetadata -> RIO env TreeKey
getArchiveKey RawPackageLocationImmutable
pl RawArchive
archive RawPackageMetadata
pm
        RPLIRepo Repo
repo RawPackageMetadata
pm -> Repo -> RawPackageMetadata -> RIO env TreeKey
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Repo -> RawPackageMetadata -> RIO env TreeKey
getRepoKey Repo
repo RawPackageMetadata
pm

-- | Get the 'TreeKey' of the package at the given location.
--
-- @since 0.1.0.0
getPackageLocationTreeKey
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => PackageLocationImmutable
  -> RIO env TreeKey
getPackageLocationTreeKey :: PackageLocationImmutable -> RIO env TreeKey
getPackageLocationTreeKey PackageLocationImmutable
pl = TreeKey -> RIO env TreeKey
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TreeKey -> RIO env TreeKey) -> TreeKey -> RIO env TreeKey
forall a b. (a -> b) -> a -> b
$ PackageLocationImmutable -> TreeKey
getTreeKey PackageLocationImmutable
pl

getRawTreeKey :: RawPackageLocationImmutable -> Maybe TreeKey
getRawTreeKey :: RawPackageLocationImmutable -> Maybe TreeKey
getRawTreeKey (RPLIHackage PackageIdentifierRevision
_ Maybe TreeKey
mtree) = Maybe TreeKey
mtree
getRawTreeKey (RPLIArchive RawArchive
_ RawPackageMetadata
rpm) = RawPackageMetadata -> Maybe TreeKey
rpmTreeKey RawPackageMetadata
rpm
getRawTreeKey (RPLIRepo Repo
_ RawPackageMetadata
rpm) = RawPackageMetadata -> Maybe TreeKey
rpmTreeKey RawPackageMetadata
rpm

getTreeKey :: PackageLocationImmutable -> TreeKey
getTreeKey :: PackageLocationImmutable -> TreeKey
getTreeKey (PLIHackage PackageIdentifier
_ BlobKey
_ TreeKey
tree) = TreeKey
tree
getTreeKey (PLIArchive Archive
_ PackageMetadata
pm) = PackageMetadata -> TreeKey
pmTreeKey PackageMetadata
pm
getTreeKey (PLIRepo Repo
_ PackageMetadata
pm) = PackageMetadata -> TreeKey
pmTreeKey PackageMetadata
pm

-- | Convenient data type that allows you to work with pantry more
-- easily than using 'withPantryConfig' directly. Uses basically sane
-- settings, like sharing a pantry directory with Stack.
--
-- You can use 'runPantryApp' to use this.
--
-- @since 0.1.0.0
data PantryApp = PantryApp
  { PantryApp -> SimpleApp
paSimpleApp :: !SimpleApp
  , PantryApp -> PantryConfig
paPantryConfig :: !PantryConfig
  , PantryApp -> Bool
paUseColor :: !Bool
  , PantryApp -> Int
paTermWidth :: !Int
  , PantryApp -> StylesUpdate
paStylesUpdate :: !StylesUpdate
  }

simpleAppL :: Lens' PantryApp SimpleApp
simpleAppL :: (SimpleApp -> f SimpleApp) -> PantryApp -> f PantryApp
simpleAppL = (PantryApp -> SimpleApp)
-> (PantryApp -> SimpleApp -> PantryApp)
-> Lens PantryApp PantryApp SimpleApp SimpleApp
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens PantryApp -> SimpleApp
paSimpleApp (\PantryApp
x SimpleApp
y -> PantryApp
x { paSimpleApp :: SimpleApp
paSimpleApp = SimpleApp
y })

-- | Lens to view or modify the 'HpackExecutable' of a 'PantryConfig'
--
-- @since 0.1.0.0
hpackExecutableL :: Lens' PantryConfig HpackExecutable
hpackExecutableL :: (HpackExecutable -> f HpackExecutable)
-> PantryConfig -> f PantryConfig
hpackExecutableL HpackExecutable -> f HpackExecutable
k PantryConfig
pconfig = (HpackExecutable -> PantryConfig)
-> f HpackExecutable -> f PantryConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\HpackExecutable
hpExe -> PantryConfig
pconfig { pcHpackExecutable :: HpackExecutable
pcHpackExecutable = HpackExecutable
hpExe }) (HpackExecutable -> f HpackExecutable
k (PantryConfig -> HpackExecutable
pcHpackExecutable PantryConfig
pconfig))

instance HasLogFunc PantryApp where
  logFuncL :: (LogFunc -> f LogFunc) -> PantryApp -> f PantryApp
logFuncL = (SimpleApp -> f SimpleApp) -> PantryApp -> f PantryApp
Lens PantryApp PantryApp SimpleApp SimpleApp
simpleAppL((SimpleApp -> f SimpleApp) -> PantryApp -> f PantryApp)
-> ((LogFunc -> f LogFunc) -> SimpleApp -> f SimpleApp)
-> (LogFunc -> f LogFunc)
-> PantryApp
-> f PantryApp
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(LogFunc -> f LogFunc) -> SimpleApp -> f SimpleApp
forall env. HasLogFunc env => Lens' env LogFunc
logFuncL
instance HasPantryConfig PantryApp where
  pantryConfigL :: (PantryConfig -> f PantryConfig) -> PantryApp -> f PantryApp
pantryConfigL = (PantryApp -> PantryConfig)
-> (PantryApp -> PantryConfig -> PantryApp)
-> Lens' PantryApp PantryConfig
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens PantryApp -> PantryConfig
paPantryConfig (\PantryApp
x PantryConfig
y -> PantryApp
x { paPantryConfig :: PantryConfig
paPantryConfig = PantryConfig
y })
instance HasProcessContext PantryApp where
  processContextL :: (ProcessContext -> f ProcessContext) -> PantryApp -> f PantryApp
processContextL = (SimpleApp -> f SimpleApp) -> PantryApp -> f PantryApp
Lens PantryApp PantryApp SimpleApp SimpleApp
simpleAppL((SimpleApp -> f SimpleApp) -> PantryApp -> f PantryApp)
-> ((ProcessContext -> f ProcessContext)
    -> SimpleApp -> f SimpleApp)
-> (ProcessContext -> f ProcessContext)
-> PantryApp
-> f PantryApp
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ProcessContext -> f ProcessContext) -> SimpleApp -> f SimpleApp
forall env. HasProcessContext env => Lens' env ProcessContext
processContextL
instance HasStylesUpdate PantryApp where
  stylesUpdateL :: (StylesUpdate -> f StylesUpdate) -> PantryApp -> f PantryApp
stylesUpdateL = (PantryApp -> StylesUpdate)
-> (PantryApp -> StylesUpdate -> PantryApp)
-> Lens' PantryApp StylesUpdate
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens PantryApp -> StylesUpdate
paStylesUpdate (\PantryApp
x StylesUpdate
y -> PantryApp
x { paStylesUpdate :: StylesUpdate
paStylesUpdate = StylesUpdate
y })
instance HasTerm PantryApp where
  useColorL :: (Bool -> f Bool) -> PantryApp -> f PantryApp
useColorL = (PantryApp -> Bool)
-> (PantryApp -> Bool -> PantryApp) -> Lens' PantryApp Bool
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens PantryApp -> Bool
paUseColor (\PantryApp
x Bool
y -> PantryApp
x { paUseColor :: Bool
paUseColor = Bool
y })
  termWidthL :: (Int -> f Int) -> PantryApp -> f PantryApp
termWidthL = (PantryApp -> Int)
-> (PantryApp -> Int -> PantryApp) -> Lens' PantryApp Int
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens PantryApp -> Int
paTermWidth  (\PantryApp
x Int
y -> PantryApp
x { paTermWidth :: Int
paTermWidth = Int
y })

-- | Run some code against pantry using basic sane settings.
--
-- For testing, see 'runPantryAppClean'.
--
-- @since 0.1.0.0
runPantryApp :: MonadIO m => RIO PantryApp a -> m a
runPantryApp :: RIO PantryApp a -> m a
runPantryApp = Int -> CasaRepoPrefix -> Int -> RIO PantryApp a -> m a
forall (m :: * -> *) a.
MonadIO m =>
Int -> CasaRepoPrefix -> Int -> RIO PantryApp a -> m a
runPantryAppWith Int
8 CasaRepoPrefix
defaultCasaRepoPrefix Int
defaultCasaMaxPerRequest

-- | Run some code against pantry using basic sane settings.
--
-- For testing, see 'runPantryAppClean'.
--
-- @since 0.1.1.1
runPantryAppWith :: MonadIO m => Int -> CasaRepoPrefix -> Int -> RIO PantryApp a -> m a
runPantryAppWith :: Int -> CasaRepoPrefix -> Int -> RIO PantryApp a -> m a
runPantryAppWith Int
maxConnCount CasaRepoPrefix
casaRepoPrefix Int
casaMaxPerRequest RIO PantryApp a
f = RIO SimpleApp a -> m a
forall (m :: * -> *) a. MonadIO m => RIO SimpleApp a -> m a
runSimpleApp (RIO SimpleApp a -> m a) -> RIO SimpleApp a -> m a
forall a b. (a -> b) -> a -> b
$ do
  SimpleApp
sa <- RIO SimpleApp SimpleApp
forall r (m :: * -> *). MonadReader r m => m r
ask
  FilePath
stack <- FilePath -> RIO SimpleApp FilePath
forall (m :: * -> *). MonadIO m => FilePath -> m FilePath
getAppUserDataDirectory FilePath
"stack"
  Path Abs Dir
root <- FilePath -> RIO SimpleApp (Path Abs Dir)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Abs Dir)
parseAbsDir (FilePath -> RIO SimpleApp (Path Abs Dir))
-> FilePath -> RIO SimpleApp (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ FilePath
stack FilePath -> FilePath -> FilePath
FilePath.</> FilePath
"pantry"
  Path Abs Dir
-> HackageSecurityConfig
-> HpackExecutable
-> Int
-> CasaRepoPrefix
-> Int
-> (SnapName -> RawSnapshotLocation)
-> (PantryConfig -> RIO SimpleApp a)
-> RIO SimpleApp a
forall env a.
HasLogFunc env =>
Path Abs Dir
-> HackageSecurityConfig
-> HpackExecutable
-> Int
-> CasaRepoPrefix
-> Int
-> (SnapName -> RawSnapshotLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
withPantryConfig
    Path Abs Dir
root
    HackageSecurityConfig
defaultHackageSecurityConfig
    HpackExecutable
HpackBundled
    Int
maxConnCount
    CasaRepoPrefix
casaRepoPrefix
    Int
casaMaxPerRequest
    SnapName -> RawSnapshotLocation
defaultSnapshotLocation
    ((PantryConfig -> RIO SimpleApp a) -> RIO SimpleApp a)
-> (PantryConfig -> RIO SimpleApp a) -> RIO SimpleApp a
forall a b. (a -> b) -> a -> b
$ \PantryConfig
pc ->
      PantryApp -> RIO PantryApp a -> RIO SimpleApp a
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO
        PantryApp :: SimpleApp
-> PantryConfig -> Bool -> Int -> StylesUpdate -> PantryApp
PantryApp
          { paSimpleApp :: SimpleApp
paSimpleApp = SimpleApp
sa
          , paPantryConfig :: PantryConfig
paPantryConfig = PantryConfig
pc
          , paTermWidth :: Int
paTermWidth = Int
100
          , paUseColor :: Bool
paUseColor = Bool
True
          , paStylesUpdate :: StylesUpdate
paStylesUpdate = StylesUpdate
forall a. Monoid a => a
mempty
          }
        RIO PantryApp a
f

-- | Like 'runPantryApp', but uses an empty pantry directory instead
-- of sharing with Stack. Useful for testing.
--
-- @since 0.1.0.0
runPantryAppClean :: MonadIO m => RIO PantryApp a -> m a
runPantryAppClean :: RIO PantryApp a -> m a
runPantryAppClean RIO PantryApp a
f = IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ FilePath -> (FilePath -> IO a) -> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> (FilePath -> m a) -> m a
withSystemTempDirectory FilePath
"pantry-clean" ((FilePath -> IO a) -> IO a) -> (FilePath -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \FilePath
dir -> RIO SimpleApp a -> IO a
forall (m :: * -> *) a. MonadIO m => RIO SimpleApp a -> m a
runSimpleApp (RIO SimpleApp a -> IO a) -> RIO SimpleApp a -> IO a
forall a b. (a -> b) -> a -> b
$ do
  SimpleApp
sa <- RIO SimpleApp SimpleApp
forall r (m :: * -> *). MonadReader r m => m r
ask
  Path Abs Dir
root <- FilePath -> RIO SimpleApp (Path Abs Dir)
forall (m :: * -> *). MonadIO m => FilePath -> m (Path Abs Dir)
resolveDir' FilePath
dir
  Path Abs Dir
-> HackageSecurityConfig
-> HpackExecutable
-> Int
-> CasaRepoPrefix
-> Int
-> (SnapName -> RawSnapshotLocation)
-> (PantryConfig -> RIO SimpleApp a)
-> RIO SimpleApp a
forall env a.
HasLogFunc env =>
Path Abs Dir
-> HackageSecurityConfig
-> HpackExecutable
-> Int
-> CasaRepoPrefix
-> Int
-> (SnapName -> RawSnapshotLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
withPantryConfig
    Path Abs Dir
root
    HackageSecurityConfig
defaultHackageSecurityConfig
    HpackExecutable
HpackBundled
    Int
8
    CasaRepoPrefix
defaultCasaRepoPrefix
    Int
defaultCasaMaxPerRequest
    SnapName -> RawSnapshotLocation
defaultSnapshotLocation
    ((PantryConfig -> RIO SimpleApp a) -> RIO SimpleApp a)
-> (PantryConfig -> RIO SimpleApp a) -> RIO SimpleApp a
forall a b. (a -> b) -> a -> b
$ \PantryConfig
pc ->
      PantryApp -> RIO PantryApp a -> RIO SimpleApp a
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO
        PantryApp :: SimpleApp
-> PantryConfig -> Bool -> Int -> StylesUpdate -> PantryApp
PantryApp
          { paSimpleApp :: SimpleApp
paSimpleApp = SimpleApp
sa
          , paPantryConfig :: PantryConfig
paPantryConfig = PantryConfig
pc
          , paTermWidth :: Int
paTermWidth = Int
100
          , paUseColor :: Bool
paUseColor = Bool
True
          , paStylesUpdate :: StylesUpdate
paStylesUpdate = StylesUpdate
forall a. Monoid a => a
mempty
          }
        RIO PantryApp a
f

-- | Load the global hints from Github.
--
-- @since 0.1.0.0
loadGlobalHints
  :: (HasTerm env, HasPantryConfig env)
  => WantedCompiler
  -> RIO env (Maybe (Map PackageName Version))
loadGlobalHints :: WantedCompiler -> RIO env (Maybe (Map PackageName Version))
loadGlobalHints WantedCompiler
wc =
    Bool -> RIO env (Maybe (Map PackageName Version))
forall b a env.
(IsCabalString b, IsCabalString a, Ord a, HasPantryConfig env,
 HasTerm env) =>
Bool -> RIO env (Maybe (Map a b))
inner Bool
False
  where
    inner :: Bool -> RIO env (Maybe (Map a b))
inner Bool
alreadyDownloaded = do
      Path Abs File
dest <- RIO env (Path Abs File)
forall env. HasPantryConfig env => RIO env (Path Abs File)
getGlobalHintsFile
      Request
req <- FilePath -> RIO env Request
forall (m :: * -> *). MonadThrow m => FilePath -> m Request
parseRequest FilePath
"https://raw.githubusercontent.com/fpco/stackage-content/master/stack/global-hints.yaml"
      Bool
downloaded <- Request -> Path Abs File -> RIO env Bool
forall env. HasTerm env => Request -> Path Abs File -> RIO env Bool
download Request
req Path Abs File
dest
      Either SomeException (Maybe (Map a b))
eres <- RIO env (Maybe (Map a b))
-> RIO env (Either SomeException (Maybe (Map a b)))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (Path Abs File -> RIO env (Maybe (Map a b))
forall (m :: * -> *) a b b t.
(MonadIO m, Ord a, IsCabalString a, IsCabalString b) =>
Path b t -> m (Maybe (Map a b))
inner2 Path Abs File
dest)
      Maybe (Map a b)
mres <-
        case Either SomeException (Maybe (Map a b))
eres of
          Left SomeException
e -> Maybe (Map a b)
forall a. Maybe a
Nothing Maybe (Map a b) -> RIO env () -> RIO env (Maybe (Map a b))
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder
"Error when parsing global hints: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> SomeException -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow SomeException
e)
          Right Maybe (Map a b)
x -> Maybe (Map a b) -> RIO env (Maybe (Map a b))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Map a b)
x
      case Maybe (Map a b)
mres of
        Maybe (Map a b)
Nothing | Bool -> Bool
not Bool
alreadyDownloaded Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
downloaded -> do
          Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
            Utf8Builder
"Could not find local global hints for " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
            WantedCompiler -> Utf8Builder
forall a. Display a => a -> Utf8Builder
RIO.display WantedCompiler
wc Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
            Utf8Builder
", forcing a redownload"
          Bool
x <- Request -> Path Abs File -> RIO env Bool
forall env. HasTerm env => Request -> Path Abs File -> RIO env Bool
redownload Request
req Path Abs File
dest
          if Bool
x
            then Bool -> RIO env (Maybe (Map a b))
inner Bool
True
            else do
              Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Redownload didn't happen"
              Maybe (Map a b) -> RIO env (Maybe (Map a b))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Map a b)
forall a. Maybe a
Nothing
        Maybe (Map a b)
_ -> Maybe (Map a b) -> RIO env (Maybe (Map a b))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Map a b)
mres

    inner2 :: Path b t -> m (Maybe (Map a b))
inner2 Path b t
dest
           = IO (Maybe (Map a b)) -> m (Maybe (Map a b))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
           (IO (Maybe (Map a b)) -> m (Maybe (Map a b)))
-> IO (Maybe (Map a b)) -> m (Maybe (Map a b))
forall a b. (a -> b) -> a -> b
$ WantedCompiler -> Map WantedCompiler (Map a b) -> Maybe (Map a b)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup WantedCompiler
wc (Map WantedCompiler (Map a b) -> Maybe (Map a b))
-> (Map WantedCompiler (Map (CabalString a) (CabalString b))
    -> Map WantedCompiler (Map a b))
-> Map WantedCompiler (Map (CabalString a) (CabalString b))
-> Maybe (Map a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (CabalString a) (CabalString b) -> Map a b)
-> Map WantedCompiler (Map (CabalString a) (CabalString b))
-> Map WantedCompiler (Map a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CabalString b -> b) -> Map a (CabalString b) -> Map a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CabalString b -> b
forall a. CabalString a -> a
unCabalString (Map a (CabalString b) -> Map a b)
-> (Map (CabalString a) (CabalString b) -> Map a (CabalString b))
-> Map (CabalString a) (CabalString b)
-> Map a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (CabalString a) (CabalString b) -> Map a (CabalString b)
forall a v. Map (CabalString a) v -> Map a v
unCabalStringMap)
         (Map WantedCompiler (Map (CabalString a) (CabalString b))
 -> Maybe (Map a b))
-> IO (Map WantedCompiler (Map (CabalString a) (CabalString b)))
-> IO (Maybe (Map a b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath
-> IO (Map WantedCompiler (Map (CabalString a) (CabalString b)))
forall (m :: * -> *) a. (MonadIO m, FromJSON a) => FilePath -> m a
Yaml.decodeFileThrow (Path b t -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path b t
dest)

-- | Partition a map of global packages with its versions into a Set of
-- replaced packages and its dependencies and a map of remaining (untouched) packages.
--
-- @since 0.1.0.0
partitionReplacedDependencies ::
       Ord id
    => Map PackageName a -- ^ global packages
    -> (a -> PackageName) -- ^ package name getter
    -> (a -> id) -- ^ returns unique package id used for dependency pruning
    -> (a -> [id]) -- ^ returns unique package ids of direct package dependencies
    -> Set PackageName -- ^ overrides which global dependencies should get pruned
    -> (Map PackageName [PackageName], Map PackageName a)
partitionReplacedDependencies :: Map PackageName a
-> (a -> PackageName)
-> (a -> id)
-> (a -> [id])
-> Set PackageName
-> (Map PackageName [PackageName], Map PackageName a)
partitionReplacedDependencies Map PackageName a
globals a -> PackageName
getName a -> id
getId a -> [id]
getDeps Set PackageName
overrides =
  (State (Map PackageName [PackageName], Map PackageName a) [Bool]
 -> (Map PackageName [PackageName], Map PackageName a)
 -> (Map PackageName [PackageName], Map PackageName a))
-> (Map PackageName [PackageName], Map PackageName a)
-> State (Map PackageName [PackageName], Map PackageName a) [Bool]
-> (Map PackageName [PackageName], Map PackageName a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State (Map PackageName [PackageName], Map PackageName a) [Bool]
-> (Map PackageName [PackageName], Map PackageName a)
-> (Map PackageName [PackageName], Map PackageName a)
forall s a. State s a -> s -> s
execState (Map PackageName [PackageName]
forall a. Map PackageName [a]
replaced, Map PackageName a
forall a. Monoid a => a
mempty) (State (Map PackageName [PackageName], Map PackageName a) [Bool]
 -> (Map PackageName [PackageName], Map PackageName a))
-> State (Map PackageName [PackageName], Map PackageName a) [Bool]
-> (Map PackageName [PackageName], Map PackageName a)
forall a b. (a -> b) -> a -> b
$
    [(PackageName, a)]
-> ((PackageName, a)
    -> StateT
         (Map PackageName [PackageName], Map PackageName a) Identity Bool)
-> State (Map PackageName [PackageName], Map PackageName a) [Bool]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (Map PackageName a -> [(PackageName, a)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName a
globals) (((PackageName, a)
  -> StateT
       (Map PackageName [PackageName], Map PackageName a) Identity Bool)
 -> State (Map PackageName [PackageName], Map PackageName a) [Bool])
-> ((PackageName, a)
    -> StateT
         (Map PackageName [PackageName], Map PackageName a) Identity Bool)
-> State (Map PackageName [PackageName], Map PackageName a) [Bool]
forall a b. (a -> b) -> a -> b
$ Map id a
-> (a -> PackageName)
-> (a -> [id])
-> (PackageName, a)
-> StateT
     (Map PackageName [PackageName], Map PackageName a) Identity Bool
forall id a.
Ord id =>
Map id a
-> (a -> PackageName)
-> (a -> [id])
-> (PackageName, a)
-> State (Map PackageName [PackageName], Map PackageName a) Bool
prunePackageWithDeps Map id a
globals' a -> PackageName
getName a -> [id]
getDeps
  where
    globals' :: Map id a
globals' = [(id, a)] -> Map id a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(id, a)] -> Map id a) -> [(id, a)] -> Map id a
forall a b. (a -> b) -> a -> b
$ (a -> (id, a)) -> [a] -> [(id, a)]
forall a b. (a -> b) -> [a] -> [b]
map (a -> id
getId (a -> id) -> (a -> a) -> a -> (id, a)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& a -> a
forall a. a -> a
id) (Map PackageName a -> [a]
forall k a. Map k a -> [a]
Map.elems Map PackageName a
globals)
    replaced :: Map PackageName [a]
replaced = (a -> [a]) -> Map PackageName a -> Map PackageName [a]
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ([a] -> a -> [a]
forall a b. a -> b -> a
const []) (Map PackageName a -> Map PackageName [a])
-> Map PackageName a -> Map PackageName [a]
forall a b. (a -> b) -> a -> b
$ Map PackageName a -> Set PackageName -> Map PackageName a
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map PackageName a
globals Set PackageName
overrides

prunePackageWithDeps ::
       Ord id
    => Map id a
    -> (a -> PackageName)
    -> (a -> [id])
    -> (PackageName, a)
    -> State (Map PackageName [PackageName], Map PackageName a) Bool
prunePackageWithDeps :: Map id a
-> (a -> PackageName)
-> (a -> [id])
-> (PackageName, a)
-> State (Map PackageName [PackageName], Map PackageName a) Bool
prunePackageWithDeps Map id a
pkgs a -> PackageName
getName a -> [id]
getDeps (PackageName
pname, a
a)  = do
  (Map PackageName [PackageName]
pruned, Map PackageName a
kept) <- StateT
  (Map PackageName [PackageName], Map PackageName a)
  Identity
  (Map PackageName [PackageName], Map PackageName a)
forall s (m :: * -> *). MonadState s m => m s
get
  if PackageName -> Map PackageName [PackageName] -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member PackageName
pname Map PackageName [PackageName]
pruned
  then Bool
-> State (Map PackageName [PackageName], Map PackageName a) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  else if PackageName -> Map PackageName a -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member PackageName
pname Map PackageName a
kept
    then Bool
-> State (Map PackageName [PackageName], Map PackageName a) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    else do
      let deps :: [a]
deps = Map id a -> [a]
forall k a. Map k a -> [a]
Map.elems (Map id a -> [a]) -> Map id a -> [a]
forall a b. (a -> b) -> a -> b
$ Map id a -> Set id -> Map id a
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map id a
pkgs ([id] -> Set id
forall a. Ord a => [a] -> Set a
Set.fromList ([id] -> Set id) -> [id] -> Set id
forall a b. (a -> b) -> a -> b
$ a -> [id]
getDeps a
a)
      [PackageName]
prunedDeps <- [a]
-> (a
    -> StateT
         (Map PackageName [PackageName], Map PackageName a)
         Identity
         (Maybe PackageName))
-> StateT
     (Map PackageName [PackageName], Map PackageName a)
     Identity
     [PackageName]
forall (m :: * -> *) a b.
Monad m =>
[a] -> (a -> m (Maybe b)) -> m [b]
forMaybeM [a]
deps ((a
  -> StateT
       (Map PackageName [PackageName], Map PackageName a)
       Identity
       (Maybe PackageName))
 -> StateT
      (Map PackageName [PackageName], Map PackageName a)
      Identity
      [PackageName])
-> (a
    -> StateT
         (Map PackageName [PackageName], Map PackageName a)
         Identity
         (Maybe PackageName))
-> StateT
     (Map PackageName [PackageName], Map PackageName a)
     Identity
     [PackageName]
forall a b. (a -> b) -> a -> b
$ \a
dep -> do
        let depName :: PackageName
depName = a -> PackageName
getName a
dep
        Bool
isPruned <- Map id a
-> (a -> PackageName)
-> (a -> [id])
-> (PackageName, a)
-> State (Map PackageName [PackageName], Map PackageName a) Bool
forall id a.
Ord id =>
Map id a
-> (a -> PackageName)
-> (a -> [id])
-> (PackageName, a)
-> State (Map PackageName [PackageName], Map PackageName a) Bool
prunePackageWithDeps Map id a
pkgs a -> PackageName
getName a -> [id]
getDeps (PackageName
depName, a
dep)
        Maybe PackageName
-> StateT
     (Map PackageName [PackageName], Map PackageName a)
     Identity
     (Maybe PackageName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe PackageName
 -> StateT
      (Map PackageName [PackageName], Map PackageName a)
      Identity
      (Maybe PackageName))
-> Maybe PackageName
-> StateT
     (Map PackageName [PackageName], Map PackageName a)
     Identity
     (Maybe PackageName)
forall a b. (a -> b) -> a -> b
$ if Bool
isPruned then PackageName -> Maybe PackageName
forall a. a -> Maybe a
Just PackageName
depName else Maybe PackageName
forall a. Maybe a
Nothing
      if [PackageName] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
prunedDeps
      then do
        ((Map PackageName [PackageName], Map PackageName a)
 -> (Map PackageName [PackageName], Map PackageName a))
-> StateT
     (Map PackageName [PackageName], Map PackageName a) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (((Map PackageName [PackageName], Map PackageName a)
  -> (Map PackageName [PackageName], Map PackageName a))
 -> StateT
      (Map PackageName [PackageName], Map PackageName a) Identity ())
-> ((Map PackageName [PackageName], Map PackageName a)
    -> (Map PackageName [PackageName], Map PackageName a))
-> StateT
     (Map PackageName [PackageName], Map PackageName a) Identity ()
forall a b. (a -> b) -> a -> b
$ (Map PackageName a -> Map PackageName a)
-> (Map PackageName [PackageName], Map PackageName a)
-> (Map PackageName [PackageName], Map PackageName a)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (PackageName -> a -> Map PackageName a -> Map PackageName a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PackageName
pname a
a)
      else do
        ((Map PackageName [PackageName], Map PackageName a)
 -> (Map PackageName [PackageName], Map PackageName a))
-> StateT
     (Map PackageName [PackageName], Map PackageName a) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (((Map PackageName [PackageName], Map PackageName a)
  -> (Map PackageName [PackageName], Map PackageName a))
 -> StateT
      (Map PackageName [PackageName], Map PackageName a) Identity ())
-> ((Map PackageName [PackageName], Map PackageName a)
    -> (Map PackageName [PackageName], Map PackageName a))
-> StateT
     (Map PackageName [PackageName], Map PackageName a) Identity ()
forall a b. (a -> b) -> a -> b
$ (Map PackageName [PackageName] -> Map PackageName [PackageName])
-> (Map PackageName [PackageName], Map PackageName a)
-> (Map PackageName [PackageName], Map PackageName a)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (PackageName
-> [PackageName]
-> Map PackageName [PackageName]
-> Map PackageName [PackageName]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PackageName
pname [PackageName]
prunedDeps)
      Bool
-> State (Map PackageName [PackageName], Map PackageName a) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
 -> State (Map PackageName [PackageName], Map PackageName a) Bool)
-> Bool
-> State (Map PackageName [PackageName], Map PackageName a) Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not ([PackageName] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
prunedDeps)

-- | Use a snapshot cache, which caches which modules are in which
-- packages in a given snapshot. This is mostly intended for usage by
-- Stack.
--
-- @since 0.1.0.0
withSnapshotCache
  :: (HasPantryConfig env, HasLogFunc env)
  => SnapshotCacheHash
  -> RIO env (Map PackageName (Set ModuleName))
  -> ((ModuleName -> RIO env [PackageName]) -> RIO env a)
  -> RIO env a
withSnapshotCache :: SnapshotCacheHash
-> RIO env (Map PackageName (Set ModuleName))
-> ((ModuleName -> RIO env [PackageName]) -> RIO env a)
-> RIO env a
withSnapshotCache SnapshotCacheHash
hash RIO env (Map PackageName (Set ModuleName))
getModuleMapping (ModuleName -> RIO env [PackageName]) -> RIO env a
f = do
  Maybe SnapshotCacheId
mres <- ReaderT SqlBackend (RIO env) (Maybe SnapshotCacheId)
-> RIO env (Maybe SnapshotCacheId)
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) (Maybe SnapshotCacheId)
 -> RIO env (Maybe SnapshotCacheId))
-> ReaderT SqlBackend (RIO env) (Maybe SnapshotCacheId)
-> RIO env (Maybe SnapshotCacheId)
forall a b. (a -> b) -> a -> b
$ SnapshotCacheHash
-> ReaderT SqlBackend (RIO env) (Maybe SnapshotCacheId)
forall env.
SnapshotCacheHash
-> ReaderT SqlBackend (RIO env) (Maybe SnapshotCacheId)
getSnapshotCacheByHash SnapshotCacheHash
hash
  SnapshotCacheId
cacheId <- case Maybe SnapshotCacheId
mres of
    Maybe SnapshotCacheId
Nothing -> do
      Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Populating snapshot module name cache"
      Map PackageName (Set ModuleName)
packageModules <- RIO env (Map PackageName (Set ModuleName))
getModuleMapping
      ReaderT SqlBackend (RIO env) SnapshotCacheId
-> RIO env SnapshotCacheId
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) SnapshotCacheId
 -> RIO env SnapshotCacheId)
-> ReaderT SqlBackend (RIO env) SnapshotCacheId
-> RIO env SnapshotCacheId
forall a b. (a -> b) -> a -> b
$ do
        SnapshotCacheId
scId <- SnapshotCacheHash -> ReaderT SqlBackend (RIO env) SnapshotCacheId
forall env.
SnapshotCacheHash -> ReaderT SqlBackend (RIO env) SnapshotCacheId
getSnapshotCacheId SnapshotCacheHash
hash
        SnapshotCacheId
-> Map PackageName (Set ModuleName)
-> ReaderT SqlBackend (RIO env) ()
forall env.
SnapshotCacheId
-> Map PackageName (Set ModuleName)
-> ReaderT SqlBackend (RIO env) ()
storeSnapshotModuleCache SnapshotCacheId
scId Map PackageName (Set ModuleName)
packageModules
        SnapshotCacheId -> ReaderT SqlBackend (RIO env) SnapshotCacheId
forall (m :: * -> *) a. Monad m => a -> m a
return SnapshotCacheId
scId
    Just SnapshotCacheId
scId -> SnapshotCacheId -> RIO env SnapshotCacheId
forall (f :: * -> *) a. Applicative f => a -> f a
pure SnapshotCacheId
scId
  (ModuleName -> RIO env [PackageName]) -> RIO env a
f ((ModuleName -> RIO env [PackageName]) -> RIO env a)
-> (ModuleName -> RIO env [PackageName]) -> RIO env a
forall a b. (a -> b) -> a -> b
$ ReaderT SqlBackend (RIO env) [PackageName] -> RIO env [PackageName]
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) [PackageName]
 -> RIO env [PackageName])
-> (ModuleName -> ReaderT SqlBackend (RIO env) [PackageName])
-> ModuleName
-> RIO env [PackageName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapshotCacheId
-> ModuleName -> ReaderT SqlBackend (RIO env) [PackageName]
forall env.
SnapshotCacheId
-> ModuleName -> ReaderT SqlBackend (RIO env) [PackageName]
loadExposedModulePackages SnapshotCacheId
cacheId

-- | Add an s to the builder if n!=1.
plural :: Int -> Utf8Builder -> Utf8Builder
plural :: Int -> Utf8Builder -> Utf8Builder
plural Int
n Utf8Builder
text =
  Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Int
n Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
text Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
  (if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
     then Utf8Builder
""
     else Utf8Builder
"s")