{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TupleSections       #-}

-- | 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
  , PackageIndexConfig (..)
  , HackageSecurityConfig (..)
  , defaultPackageIndexConfig
  , defaultDownloadPrefix
  , defaultHackageSecurityConfig
  , defaultCasaRepoPrefix
  , defaultCasaMaxPerRequest
  , defaultSnapshotLocation
  , HasPantryConfig (..)
  , withPantryConfig
  , withPantryConfig'
  , HpackExecutable (..)

    -- ** Convenience

  , PantryApp
  , runPantryApp
  , runPantryAppClean
  , runPantryAppWith
  , hpackExecutableL

    -- * Types


    -- ** Exceptions

  , PantryException (..)
  , Mismatch (..)
  , FuzzyResults (..)

    -- ** Cabal types

  , PackageName
  , Version
  , FlagName
  , PackageIdentifier (..)

    -- ** Files

  , FileSize (..)
  , RelFilePath (..)
  , ResolvedPath (..)
  , Unresolved
  , SafeFilePath
  , mkSafeFilePath

    -- ** Cryptography

  , SHA256
  , TreeKey (..)
  , BlobKey (..)

    -- ** Packages

  , RawPackageMetadata (..)
  , PackageMetadata (..)
  , Package (..)

    -- ** Hackage

  , CabalFileInfo (..)
  , Revision (..)
  , PackageIdentifierRevision (..)
  , UsePreferredVersions (..)

    -- ** Archives

  , RawArchive (..)
  , Archive (..)
  , ArchiveLocation (..)

    -- ** Repos

  , Repo (..)
  , RepoType (..)
  , SimpleRepo (..)
  , withRepo
  , fetchRepos
  , fetchReposRaw

    -- ** 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
  , loadAndCompleteSnapshot'
  , loadAndCompleteSnapshotRaw
  , 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           Casa.Client ( CasaRepoPrefix, thParserCasaRepo )
import           Conduit
import           Control.Arrow ( right )
import           Control.Monad.State.Strict ( State, execState, get, modify' )
import           Data.Aeson.Types ( Value, parseEither )
import           Data.Aeson.WarningParser ( WithJSONWarnings (..) )
#if !MIN_VERSION_rio(0,1,17)
import           Data.Bifunctor ( bimap )
#endif
import           Data.Char ( isHexDigit )
import           Data.Monoid ( Endo (..) )
import           Data.Time ( diffUTCTime, getCurrentTime )
import qualified Data.Yaml as Yaml
import           Data.Yaml.Include ( decodeFileWithWarnings )
import           Database.Persist ( entityKey )
import           Distribution.PackageDescription
                   ( FlagName, GenericPackageDescription )
import qualified Distribution.PackageDescription as D
import           Distribution.Parsec ( PWarning (..), showPos )
import qualified Hpack
import qualified Hpack.Config as Hpack
import           Hpack.Error ( formatHpackError )
import           Hpack.Yaml ( formatWarning )
import           Network.HTTP.Download
import           Pantry.Archive
import           Pantry.Casa
import           Pantry.HTTP
import           Pantry.Hackage
import           Pantry.Repo
import qualified Pantry.SHA256 as SHA256
import           Pantry.Storage hiding
                   ( TreeEntry, PackageName, Version, findOrGenerateCabalFile )
import           Pantry.Tree
import           Pantry.Types as P
import           Path
                   ( Abs, Dir, File, Path, (</>), filename, parent, parseAbsDir
                   , parseRelFile, toFilePath
                   )
import           Path.IO ( doesFileExist, listDir, resolveDir' )
import           RIO
import qualified RIO.ByteString as B
import           RIO.Directory ( getAppUserDataDirectory )
import qualified RIO.FilePath as FilePath
import qualified RIO.List as List
import qualified RIO.Map as Map
import           RIO.PrettyPrint
import           RIO.PrettyPrint.StylesUpdate
import           RIO.Process
import qualified RIO.Set as Set
import           RIO.Text ( unpack )
import qualified RIO.Text as T
import           System.IO.Error ( isDoesNotExistError )

decodeYaml :: FilePath -> IO (Either String ([String], Value))
decodeYaml :: String -> IO (Either String ([String], Value))
decodeYaml String
file = do
  forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall e. Exception e => e -> String
displayException (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [Warning] -> [String]
formatWarnings) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
FromJSON a =>
String -> IO (Either ParseException ([Warning], a))
decodeFileWithWarnings String
file
  where
    formatWarnings :: [Warning] -> [String]
formatWarnings = forall a b. (a -> b) -> [a] -> [b]
map (String -> Warning -> String
formatWarning String
file)

formatYamlParseError :: FilePath -> Yaml.ParseException -> String
formatYamlParseError :: String -> ParseException -> String
formatYamlParseError String
file ParseException
e =
  String
"In respect of an Hpack defaults file:\n"
  forall a. Semigroup a => a -> a -> a
<> String
file
  forall a. Semigroup a => a -> a -> a
<> String
":\n\n"
  forall a. Semigroup a => a -> a -> a
<> forall e. Exception e => e -> String
displayException ParseException
e

-- | Create a new 'PantryConfig' with the given settings. For a version where

-- the use of Casa (content-addressable storage archive) is optional, see

-- 'withPantryConfig''.

--

-- 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.

  -> PackageIndexConfig
     -- ^ Package index configuration. You probably want

     -- 'defaultPackageIndexConfig'.

  -> 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.stackage.org/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 :: forall env a.
HasLogFunc env =>
Path Abs Dir
-> PackageIndexConfig
-> HpackExecutable
-> Int
-> CasaRepoPrefix
-> Int
-> (SnapName -> RawSnapshotLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
withPantryConfig Path Abs Dir
root PackageIndexConfig
pic HpackExecutable
he Int
count CasaRepoPrefix
pullURL Int
maxPerRequest =
  forall env a.
HasLogFunc env =>
Path Abs Dir
-> PackageIndexConfig
-> HpackExecutable
-> Int
-> Maybe (CasaRepoPrefix, Int)
-> (SnapName -> RawSnapshotLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
withPantryConfig' Path Abs Dir
root PackageIndexConfig
pic HpackExecutable
he Int
count (forall a. a -> Maybe a
Just (CasaRepoPrefix
pullURL, Int
maxPerRequest))

-- | Create a new 'PantryConfig' with the given settings.

--

-- For something easier to use in simple cases, see 'runPantryApp'.

--

-- @since 0.8.3

withPantryConfig'
  :: HasLogFunc env
  => Path Abs Dir
  -- ^ pantry root directory, where the SQLite database and Hackage

  -- downloads are kept.

  -> PackageIndexConfig
  -- ^ Package index configuration. You probably want

  -- 'defaultPackageIndexConfig'.

  -> HpackExecutable
  -- ^ When converting an hpack @package.yaml@ file to a cabal file,

  -- what version of hpack should we use?

  -> Int
  -- ^ Maximum connection count

  -> Maybe (CasaRepoPrefix, Int)
  -- ^ Optionally, the Casa pull URL e.g. @https://casa.fpcomplete.com@ and the

  -- maximum number of 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' :: forall env a.
HasLogFunc env =>
Path Abs Dir
-> PackageIndexConfig
-> HpackExecutable
-> Int
-> Maybe (CasaRepoPrefix, Int)
-> (SnapName -> RawSnapshotLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
withPantryConfig' Path Abs Dir
root PackageIndexConfig
pic HpackExecutable
he Int
count Maybe (CasaRepoPrefix, Int)
mCasaConfig SnapName -> RawSnapshotLocation
snapLoc PantryConfig -> RIO env a
inner = do
  env
env <- forall r (m :: * -> *). MonadReader r m => m r
ask
  Path Rel File
pantryRelFile <- forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile String
"pantry.sqlite3"
  -- Silence persistent's logging output, which is really noisy

  forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO (forall a. Monoid a => a
mempty :: LogFunc) forall a b. (a -> b) -> a -> b
$ forall env a.
HasLogFunc env =>
Path Abs File -> (Storage -> RIO env a) -> RIO env a
initStorage (Path Abs Dir
root forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
pantryRelFile) forall a b. (a -> b) -> a -> b
$ \Storage
storage -> forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO env
env forall a b. (a -> b) -> a -> b
$ do
    MVar Bool
ur <- forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar Bool
True
    IORef (Map RawPackageLocationImmutable GenericPackageDescription)
ref1 <- forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef forall a. Monoid a => a
mempty
    IORef
  (Map
     (Path Abs Dir)
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File))
ref2 <- forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef forall a. Monoid a => a
mempty
    PantryConfig -> RIO env a
inner PantryConfig
      { pcPackageIndex :: PackageIndexConfig
pcPackageIndex = PackageIndexConfig
pic
      , 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
      , pcCasaConfig :: Maybe (CasaRepoPrefix, Int)
pcCasaConfig = Maybe (CasaRepoPrefix, Int)
mCasaConfig
      , 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.stackage.org")

-- | Default max keys to pull per request.

--

-- @since 0.1.1.1

defaultCasaMaxPerRequest :: Int
defaultCasaMaxPerRequest :: Int
defaultCasaMaxPerRequest = Int
1280

-- | Default 'PackageIndexConfig' value using the official Hackage server.

--

-- @since 0.6.0

defaultPackageIndexConfig :: PackageIndexConfig
defaultPackageIndexConfig :: PackageIndexConfig
defaultPackageIndexConfig = PackageIndexConfig
  { picDownloadPrefix :: Text
picDownloadPrefix = Text
defaultDownloadPrefix
  , picHackageSecurityConfig :: HackageSecurityConfig
picHackageSecurityConfig = HackageSecurityConfig
defaultHackageSecurityConfig
  }

-- | The download prefix for the official Hackage server.

--

-- @since 0.6.0

defaultDownloadPrefix :: Text
defaultDownloadPrefix :: Text
defaultDownloadPrefix = Text
"https://hackage.haskell.org/"

-- | 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 :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
RequireHackageIndex
-> PackageName
-> UsePreferredVersions
-> RIO env (Maybe PackageIdentifierRevision)
getLatestHackageVersion RequireHackageIndex
req PackageName
name UsePreferredVersions
preferred =
  ((forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> Maybe ((k, a), Map k a)
Map.maxViewWithKey) forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall {k}.
(Version, Map k BlobKey) -> Maybe PackageIdentifierRevision
go) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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) <- forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> Maybe ((k, a), Map k a)
Map.maxViewWithKey Map k BlobKey
m
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ PackageName
-> Version -> CabalFileInfo -> PackageIdentifierRevision
PackageIdentifierRevision PackageName
name Version
version forall a b. (a -> b) -> a -> b
$ SHA256 -> Maybe FileSize -> CabalFileInfo
CFIHash SHA256
sha forall a b. (a -> b) -> a -> b
$ 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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RequireHackageIndex
-> PackageName
-> UsePreferredVersions
-> RIO env (Maybe PackageLocationImmutable)
getLatestHackageLocation RequireHackageIndex
req PackageName
name UsePreferredVersions
preferred = do
  Maybe (Version, Map Revision BlobKey)
mversion <-
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> Maybe ((k, a), Map k a)
Map.maxViewWithKey forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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) <- forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> Maybe ((k, a), Map k a)
Map.maxViewWithKey Map Revision BlobKey
revisions
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Version
version, BlobKey
cfKey)

  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (Version, BlobKey)
mVerCfKey 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 (forall a. a -> Maybe a
Just FileSize
size))
    TreeKey
treeKey' <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageIdentifierRevision -> RIO env TreeKey
getHackageTarballKey PackageIdentifierRevision
pir
    forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RequireHackageIndex
-> PackageName
-> Version
-> RIO env (Maybe (Revision, BlobKey, TreeKey))
getLatestHackageRevision RequireHackageIndex
req PackageName
name Version
version = do
  Map Revision BlobKey
revisions <- forall env.
(HasPantryConfig env, HasLogFunc env) =>
RequireHackageIndex
-> PackageName -> Version -> RIO env (Map Revision BlobKey)
getHackagePackageVersionRevisions RequireHackageIndex
req PackageName
name Version
version
  case forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> Maybe ((k, a), Map k a)
Map.maxViewWithKey Map Revision BlobKey
revisions of
    Maybe (Revision, BlobKey)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 (forall a. a -> Maybe a
Just FileSize
size)
      TreeKey
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)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
[RawPackageLocationImmutable] -> RIO env ()
fetchTreeKeys [RawPackageLocationImmutable]
treeKeys = do
  -- Find all tree keys that are missing from the database.

  [RawPackageLocationImmutable]
packageLocationsMissing :: [RawPackageLocationImmutable] <-
    forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage
      (forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM
         (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Maybe a -> Bool
isNothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) forall env.
TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
getTreeForKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawPackageLocationImmutable -> Maybe TreeKey
getRawTreeKey)
         [RawPackageLocationImmutable]
treeKeys)
  UTCTime
pullTreeStart <- 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 <-
    forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny (forall a b. a -> b -> a
const forall a. Monoid a => a
mempty)
    (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      (forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage
         (forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes
            (forall (f :: * -> *) env i.
(Foldable f, HasPantryConfig env, HasLogFunc env) =>
f BlobKey
-> ConduitT
     i
     (BlobKey, ByteString)
     (ResourceT (ReaderT SqlBackend (RIO env)))
     ()
casaBlobSource
               (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TreeKey -> BlobKey
unTreeKey (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe RawPackageLocationImmutable -> Maybe TreeKey
getRawTreeKey [RawPackageLocationImmutable]
packageLocationsMissing)) forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.|
             forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConduitT a b m ()
mapMC forall (m :: * -> *).
MonadThrow m =>
(BlobKey, ByteString) -> m (TreeKey, Tree)
parseTreeM forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.|
             forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
sinkList))))
  UTCTime
pullTreeEnd <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  let pulledPackages :: [RawPackageLocationImmutable]
pulledPackages =
        forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
          (\TreeKey
treeKey' ->
             forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find
               ((forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just TreeKey
treeKey') forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawPackageLocationImmutable -> Maybe TreeKey
getRawTreeKey)
               [RawPackageLocationImmutable]
packageLocationsMissing)
          (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 =
        forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
          (\(P.TreeMap Map SafeFilePath TreeEntry
files) -> forall a. Ord a => [a] -> Set a
Set.fromList (forall a b. (a -> b) -> [a] -> [b]
map TreeEntry -> BlobKey
teBlob (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Map SafeFilePath TreeEntry
files)))
          Map TreeKey Tree
treeKeyBlobs
  UTCTime
pullBlobStart <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  Maybe Int
mpulledBlobKeys :: Maybe Int <-
    forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny (forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing))
    (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just (forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage
      (forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes
         (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 forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
mapC (forall a b. a -> b -> a
const Int
1) forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o. (Monad m, Num a) => ConduitT a o m a
sumC))))
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Int
mpulledBlobKeys forall a b. (a -> b) -> a -> b
$ \Int
pulledBlobKeys -> do
    UTCTime
pullBlobEnd <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug
      (Utf8Builder
"Pulled from Casa: " forall a. Semigroup a => a -> a -> a
<>
       forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
List.intersperse Utf8Builder
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Display a => a -> Utf8Builder
display [RawPackageLocationImmutable]
pulledPackages)) forall a. Semigroup a => a -> a -> a
<>
       Utf8Builder
" (" forall a. Semigroup a => a -> a -> a
<>
       forall a. Display a => a -> Utf8Builder
display (String -> Text
T.pack (forall a. Show a => a -> String
show (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
pullTreeEnd UTCTime
pullTreeStart))) forall a. Semigroup a => a -> a -> a
<>
       Utf8Builder
"), " forall a. Semigroup a => a -> a -> a
<>
       Int -> Utf8Builder -> Utf8Builder
plural Int
pulledBlobKeys Utf8Builder
"file" forall a. Semigroup a => a -> a -> a
<>
       Utf8Builder
" (" forall a. Semigroup a => a -> a -> a
<>
       forall a. Display a => a -> Utf8Builder
display (String -> Text
T.pack (forall a. Show a => a -> String
show (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
pullBlobEnd UTCTime
pullBlobStart))) forall a. Semigroup a => a -> a -> a
<>
       Utf8Builder
")")
  -- Store the tree for each missing package.

  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 ->
               forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug
                 (Utf8Builder
"Ignoring package with no tree key " forall a. Semigroup a => a -> a -> a
<>
                  forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
rawPackageLocationImmutable forall a. Semigroup a => a -> a -> a
<>
                  Utf8Builder
", can't look in Casa for it.")
             Just TreeKey
key ->
               case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TreeKey
key Map TreeKey Tree
treeKeyBlobs of
                 Maybe Tree
Nothing ->
                   forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug
                     (Utf8Builder
"Package key " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display TreeKey
key forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" (" forall a. Semigroup a => a -> a -> a
<>
                      forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
rawPackageLocationImmutable forall a. Semigroup a => a -> a -> a
<>
                      Utf8Builder
") not returned from Casa.")
                 Just Tree
tree -> do
                   PackageIdentifier
identifier <-
                     forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env PackageIdentifier
getRawPackageLocationIdent RawPackageLocationImmutable
rawPackageLocationImmutable
                   case forall (m :: * -> *).
MonadThrow m =>
RawPackageLocationImmutable -> Tree -> m BuildFile
findCabalOrHpackFile RawPackageLocationImmutable
rawPackageLocationImmutable Tree
tree of
                     Just BuildFile
buildFile -> forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage forall a b. (a -> b) -> a -> b
$ do
                       Either LoadCachedTreeException CachedTree
ecachedTree <- forall env.
Tree
-> ReaderT
     SqlBackend (RIO env) (Either LoadCachedTreeException CachedTree)
loadCachedTree Tree
tree
                       case Either LoadCachedTreeException CachedTree
ecachedTree of
                         Left LoadCachedTreeException
e ->
                           forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn
                           (Utf8Builder
"Loading cached tree after download from Casa failed on " forall a. Semigroup a => a -> a -> a
<>
                            forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
rawPackageLocationImmutable forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": " forall a. Semigroup a => a -> a -> a
<>
                            forall a. Show a => a -> Utf8Builder
displayShow LoadCachedTreeException
e)
                         Right CachedTree
cachedTree ->
                           forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> PackageIdentifier
-> CachedTree
-> BuildFile
-> ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
storeTree
                             RawPackageLocationImmutable
rawPackageLocationImmutable
                             PackageIdentifier
identifier
                             CachedTree
cachedTree
                             BuildFile
buildFile
                     Maybe BuildFile
Nothing ->
                       forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn
                         (Utf8Builder
"Unable to find build file for package: " forall a. Semigroup a => a -> a -> a
<>
                          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 :: forall env (f :: * -> *).
(HasPantryConfig env, HasLogFunc env, HasProcessContext env,
 Foldable f) =>
f PackageLocationImmutable -> RIO env ()
fetchPackages f PackageLocationImmutable
pls = do
  forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
[RawPackageLocationImmutable] -> RIO env ()
fetchTreeKeys (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f PackageLocationImmutable
pls))
  forall (f :: * -> *) env a.
(Foldable f, HasPantryConfig env) =>
(a -> RIO env ()) -> f a -> RIO env ()
traverseConcurrently_ (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry 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

  forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
[(Archive, PackageMetadata)] -> RIO env ()
fetchArchives [(Archive, PackageMetadata)]
archives
  forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
[(Repo, PackageMetadata)] -> RIO env ()
fetchRepos [(Repo, PackageMetadata)]
repos
 where
  s :: a -> Endo [a]
s a
x = forall a. (a -> a) -> Endo a
Endo (a
xforall 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) = 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 = forall {a}. Endo [a] -> [a]
run Endo [(PackageIdentifierRevision, Maybe TreeKey)]
hackagesE
  archives :: [(Archive, PackageMetadata)]
archives = forall {a}. Endo [a] -> [a]
run Endo [(Archive, PackageMetadata)]
archivesE
  repos :: [(Repo, PackageMetadata)]
repos = 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) = (forall {a}. a -> Endo [a]
s (PackageIdentifier -> BlobKey -> PackageIdentifierRevision
toPir PackageIdentifier
ident BlobKey
cfHash, forall a. a -> Maybe a
Just TreeKey
tree), forall a. Monoid a => a
mempty, forall a. Monoid a => a
mempty)
  go (PLIArchive Archive
archive PackageMetadata
pm) = (forall a. Monoid a => a
mempty, forall {a}. a -> Endo [a]
s (Archive
archive, PackageMetadata
pm), forall a. Monoid a => a
mempty)
  go (PLIRepo Repo
repo PackageMetadata
pm) = (forall a. Monoid a => a
mempty, forall a. Monoid a => a
mempty, 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 (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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir -> RawPackageLocationImmutable -> RIO env ()
unpackPackageLocationRaw Path Abs Dir
fp RawPackageLocationImmutable
loc =
  forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env Package
loadPackageRaw RawPackageLocationImmutable
loc forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawPackageLocationImmutable -> Path Abs Dir -> Tree -> RIO env ()
unpackTree RawPackageLocationImmutable
loc Path Abs Dir
fp 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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir -> PackageLocationImmutable -> RIO env ()
unpackPackageLocation Path Abs Dir
fp PackageLocationImmutable
loc =
  forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageLocationImmutable -> RIO env Package
loadPackage PackageLocationImmutable
loc forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawPackageLocationImmutable -> Path Abs Dir -> Tree -> RIO env ()
unpackTree (PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI PackageLocationImmutable
loc) Path Abs Dir
fp 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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageLocationImmutable -> RIO env GenericPackageDescription
loadCabalFileImmutable PackageLocationImmutable
loc = forall {m :: * -> *} {s}.
(MonadReader s m, HasPantryConfig s, MonadIO m) =>
m GenericPackageDescription -> m GenericPackageDescription
withCache forall a b. (a -> b) -> a -> b
$ do
  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Parsing cabal file for " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display PackageLocationImmutable
loc
  ByteString
bs <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageLocationImmutable -> RIO env ByteString
loadCabalFileBytes PackageLocationImmutable
loc
  ([PWarning]
_warnings, GenericPackageDescription
gpd) <- forall (m :: * -> *).
MonadThrow m =>
Either RawPackageLocationImmutable (Path Abs File)
-> ByteString -> m ([PWarning], GenericPackageDescription)
rawParseGPD (forall a b. a -> Either a b
Left 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
            { 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) forall a. Maybe a
Nothing
        (GenericPackageDescription -> PackageIdentifier
gpdPackageIdentifier GenericPackageDescription
gpd)
      PackageIdentifier PackageName
name Version
ver = PackageMetadata -> PackageIdentifier
pmIdent PackageMetadata
pm
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO PantryException
exc) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ do
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ PackageName
name forall a. Eq a => a -> a -> Bool
== GenericPackageDescription -> PackageName
gpdPackageName GenericPackageDescription
gpd
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Version
ver forall a. Eq a => a -> a -> Bool
== GenericPackageDescription -> Version
gpdVersion GenericPackageDescription
gpd
    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 <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig
-> IORef
     (Map RawPackageLocationImmutable GenericPackageDescription)
pcParsedCabalFilesRawImmutable
    Map RawPackageLocationImmutable GenericPackageDescription
m0 <- forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Map RawPackageLocationImmutable GenericPackageDescription)
ref
    case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RawPackageLocationImmutable
rawLoc Map RawPackageLocationImmutable GenericPackageDescription
m0 of
      Just GenericPackageDescription
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure GenericPackageDescription
x
      Maybe GenericPackageDescription
Nothing -> do
        GenericPackageDescription
x <- m GenericPackageDescription
inner
        forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef (Map RawPackageLocationImmutable GenericPackageDescription)
ref forall a b. (a -> b) -> a -> b
$ \Map RawPackageLocationImmutable GenericPackageDescription
m -> (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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env GenericPackageDescription
loadCabalFileRawImmutable RawPackageLocationImmutable
loc = forall {m :: * -> *} {s}.
(MonadReader s m, HasPantryConfig s, MonadIO m) =>
m GenericPackageDescription -> m GenericPackageDescription
withCache forall a b. (a -> b) -> a -> b
$ do
  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Parsing cabal file for " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
loc
  ByteString
bs <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env ByteString
loadRawCabalFileBytes RawPackageLocationImmutable
loc
  ([PWarning]
_warnings, GenericPackageDescription
gpd) <- forall (m :: * -> *).
MonadThrow m =>
Either RawPackageLocationImmutable (Path Abs File)
-> ByteString -> m ([PWarning], GenericPackageDescription)
rawParseGPD (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
            { rpmName :: Maybe PackageName
rpmName = forall a. a -> Maybe a
Just PackageName
name
            , rpmVersion :: Maybe Version
rpmVersion = 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 forall a. Maybe a
Nothing (GenericPackageDescription -> PackageIdentifier
gpdPackageIdentifier GenericPackageDescription
gpd)
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO PantryException
exc) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ do
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (forall a. Eq a => a -> a -> Bool
== GenericPackageDescription -> PackageName
gpdPackageName GenericPackageDescription
gpd) (RawPackageMetadata -> Maybe PackageName
rpmName RawPackageMetadata
rpm)
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (forall a. Eq a => a -> a -> Bool
== GenericPackageDescription -> Version
gpdVersion GenericPackageDescription
gpd) (RawPackageMetadata -> Maybe Version
rpmVersion RawPackageMetadata
rpm)
    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 <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig
-> IORef
     (Map RawPackageLocationImmutable GenericPackageDescription)
pcParsedCabalFilesRawImmutable
    Map RawPackageLocationImmutable GenericPackageDescription
m0 <- forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Map RawPackageLocationImmutable GenericPackageDescription)
ref
    case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RawPackageLocationImmutable
loc Map RawPackageLocationImmutable GenericPackageDescription
m0 of
      Just GenericPackageDescription
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure GenericPackageDescription
x
      Maybe GenericPackageDescription
Nothing -> do
        GenericPackageDescription
x <- m GenericPackageDescription
inner
        forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef (Map RawPackageLocationImmutable GenericPackageDescription)
ref forall a b. (a -> b) -> a -> b
$ \Map RawPackageLocationImmutable GenericPackageDescription
m -> (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.8.0

loadCabalFileRaw ::
     (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => Maybe Text
     -- ^ The program name used by Hpack (the library), defaults to \"hpack\".

  -> RawPackageLocation
  -> RIO env GenericPackageDescription
loadCabalFileRaw :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text
-> RawPackageLocation -> RIO env GenericPackageDescription
loadCabalFileRaw Maybe Text
_ (RPLImmutable RawPackageLocationImmutable
loc) = forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env GenericPackageDescription
loadCabalFileRawImmutable RawPackageLocationImmutable
loc
loadCabalFileRaw Maybe Text
progName (RPLMutable ResolvedPath Dir
rfp) = do
  (PrintWarnings -> IO GenericPackageDescription
gpdio, PackageName
_, Path Abs File
_) <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text
-> Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
loadCabalFilePath Maybe Text
progName (forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath Dir
rfp)
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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.8.0

loadCabalFile ::
     (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => Maybe Text
     -- ^ The program name used by Hpack (the library), defaults to \"hpack\".

  -> PackageLocation
  -> RIO env GenericPackageDescription
loadCabalFile :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text -> PackageLocation -> RIO env GenericPackageDescription
loadCabalFile Maybe Text
_ (PLImmutable PackageLocationImmutable
loc) = forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageLocationImmutable -> RIO env GenericPackageDescription
loadCabalFileImmutable PackageLocationImmutable
loc
loadCabalFile Maybe Text
progName (PLMutable ResolvedPath Dir
rfp) = do
  (PrintWarnings -> IO GenericPackageDescription
gpdio, PackageName
_, Path Abs File
_) <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text
-> Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
loadCabalFilePath Maybe Text
progName (forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath Dir
rfp)
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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.8.0

loadCabalFilePath ::
     (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => Maybe Text
     -- ^ The program name used by Hpack (the library), defaults to \"hpack\".

  -> Path Abs Dir -- ^ project directory, with a cabal file or hpack file

  -> RIO env
       ( PrintWarnings -> IO GenericPackageDescription
       , PackageName
       , Path Abs File
       )
loadCabalFilePath :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text
-> Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
loadCabalFilePath Maybe Text
progName Path Abs Dir
dir = do
  IORef
  (Map
     (Path Abs Dir)
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File))
ref <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.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 <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Path Abs Dir
dir forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 -> 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) <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text -> Path Abs Dir -> RIO env (PackageName, Path Abs File)
findOrGenerateCabalFile Maybe Text
progName Path Abs Dir
dir
      IORef (Maybe ([PWarning], GenericPackageDescription))
gpdRef <- forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef forall a. Maybe a
Nothing
      RIO env GenericPackageDescription -> IO GenericPackageDescription
run <- forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
      let gpdio :: PrintWarnings -> IO GenericPackageDescription
gpdio = RIO env GenericPackageDescription -> IO GenericPackageDescription
run forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)
      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 forall a b. (a -> b) -> a -> b
$ \Map
  (Path Abs Dir)
  (PrintWarnings -> IO GenericPackageDescription, PackageName,
   Path Abs File)
m -> (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 <- 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([PWarning], GenericPackageDescription)
pair
          Maybe ([PWarning], GenericPackageDescription)
Nothing -> do
            ByteString
bs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => String -> m ByteString
B.readFile forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> String
toFilePath Path Abs File
cabalfp
            ([PWarning]
warnings0, GenericPackageDescription
gpd) <- forall (m :: * -> *).
MonadThrow m =>
Either RawPackageLocationImmutable (Path Abs File)
-> ByteString -> m ([PWarning], GenericPackageDescription)
rawParseGPD (forall a b. b -> Either a b
Right Path Abs File
cabalfp) ByteString
bs
            forall (m :: * -> *).
MonadThrow m =>
PackageName -> Path Abs File -> m ()
checkCabalFileName (GenericPackageDescription -> PackageName
gpdPackageName GenericPackageDescription
gpd) Path Abs File
cabalfp
            forall (f :: * -> *) a. Applicative f => a -> f a
pure ([PWarning]
warnings0, GenericPackageDescription
gpd)
      [PWarning]
warnings <-
        case PrintWarnings
printWarnings of
          PrintWarnings
YesPrintWarnings -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> PWarning -> Utf8Builder
toPretty Path Abs File
cabalfp) [PWarning]
warnings0 forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> []
          PrintWarnings
NoPrintWarnings -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [PWarning]
warnings0
      forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef (Maybe ([PWarning], GenericPackageDescription))
gpdRef forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ([PWarning]
warnings, GenericPackageDescription
gpd)
      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 String
msg) =
      Utf8Builder
"Cabal file warning in " forall a. Semigroup a => a -> a -> a
<>
      forall a. IsString a => String -> a
fromString (forall b t. Path b t -> String
toFilePath Path Abs File
src) forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"@" forall a. Semigroup a => a -> a -> a
<>
      forall a. IsString a => String -> a
fromString (Position -> String
showPos Position
pos) forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": " forall a. Semigroup a => a -> a -> a
<>
      forall a. IsString a => String -> a
fromString String
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 :: forall (m :: * -> *).
MonadThrow m =>
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 :: String
expected = Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ SafeFilePath -> Text
unSafeFilePath forall a b. (a -> b) -> a -> b
$ PackageName -> SafeFilePath
cabalFileName PackageName
name
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
expected forall a. Eq a => a -> a -> Bool
/= forall b t. Path b t -> String
toFilePath (forall b. Path b File -> Path Rel File
filename Path Abs File
cabalfp)) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Path Abs File -> PackageName -> PantryException
MismatchedCabalName Path Abs File
cabalfp PackageName
name

-- | Get the file name 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.8.0

findOrGenerateCabalFile ::
     forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => Maybe Text
     -- ^ The program name used by Hpack (the library), defaults to \"hpack\".

  -> Path Abs Dir -- ^ package directory

  -> RIO env (PackageName, Path Abs File)
findOrGenerateCabalFile :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text -> Path Abs Dir -> RIO env (PackageName, Path Abs File)
findOrGenerateCabalFile Maybe Text
progName Path Abs Dir
pkgDir = do
  let hpackProgName :: Maybe ProgramName
hpackProgName = forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
progName
  forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe ProgramName -> Path Abs Dir -> RIO env ()
hpack Maybe ProgramName
hpackProgName Path Abs Dir
pkgDir
  ([Path Abs Dir]
_, [Path Abs File]
allFiles) <- forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
pkgDir forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (IOException -> m a) -> m a
`catchIO` \IOException
e -> if IOException -> Bool
isDoesNotExistError IOException
e
    then forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> PantryException
NoLocalPackageDirFound Path Abs Dir
pkgDir
    else forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO IOException
e
  let files :: [Path Abs File]
files = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> String -> Bool
hasExtension String
"cabal" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> String
toFilePath) [Path Abs File]
allFiles
  -- 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 :: String -> Bool
isHidden (Char
'.':String
_) = Bool
True
      isHidden String
_ = Bool
False
  case forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isHidden forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> String
toFilePath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. Path b File -> Path Rel File
filename) [Path Abs File]
files of
    [] -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> PantryException
NoCabalFileFound Path Abs Dir
pkgDir
    [Path Abs File
x] -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      (forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Path Abs File -> PantryException
InvalidCabalFilePath Path Abs File
x)
      (\PackageName
pn -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageName
pn, Path Abs File
x)) forall a b. (a -> b) -> a -> b
$
        forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripSuffix String
".cabal" (forall b t. Path b t -> String
toFilePath (forall b. Path b File -> Path Rel File
filename Path Abs File
x)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        String -> Maybe PackageName
parsePackageName
    Path Abs File
_:[Path Abs File]
_ -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> [Path Abs File] -> PantryException
MultipleCabalFilesFound Path Abs Dir
pkgDir [Path Abs File]
files
 where
  hasExtension :: String -> String -> Bool
hasExtension String
fp String
x = String -> String
FilePath.takeExtension String
fp forall a. Eq a => a -> a -> Bool
== String
"." forall a. [a] -> [a] -> [a]
++ String
x

-- | Generate Cabal file from package.yaml, if necessary.

hpack ::
     (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => Maybe Hpack.ProgramName -- ^ The program name used by Hpack (the library).

  -> Path Abs Dir
  -> RIO env ()
hpack :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe ProgramName -> Path Abs Dir -> RIO env ()
hpack Maybe ProgramName
progName Path Abs Dir
pkgDir = do
  Path Rel File
packageConfigRelFile <- forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile String
Hpack.packageConfig
  let hpackFile :: Path Abs File
hpackFile = Path Abs Dir
pkgDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
packageConfigRelFile
      mHpackProgName :: Options -> Options
mHpackProgName = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id ProgramName -> Options -> Options
Hpack.setProgramName Maybe ProgramName
progName
  Bool
exists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
hpackFile
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Running Hpack on " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (forall b t. Path b t -> String
toFilePath Path Abs File
hpackFile)
    HpackExecutable
he <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig -> HpackExecutable
pcHpackExecutable
    case HpackExecutable
he of
      HpackExecutable
HpackBundled ->
                  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
                     ( Options -> IO (Either HpackError Result)
Hpack.hpackResultWithError
                     forall a b. (a -> b) -> a -> b
$ Options -> Options
mHpackProgName
                     forall a b. (a -> b) -> a -> b
$ (String -> IO (Either String ([String], Value)))
-> Options -> Options
Hpack.setDecode String -> IO (Either String ([String], Value))
decodeYaml
                     forall a b. (a -> b) -> a -> b
$ (String -> ParseException -> String) -> Options -> Options
Hpack.setFormatYamlParseError String -> ParseException -> String
formatYamlParseError
                     forall a b. (a -> b) -> a -> b
$ String -> Options -> Options
Hpack.setTarget
                         (forall b t. Path b t -> String
toFilePath Path Abs File
hpackFile) Options
Hpack.defaultOptions
                     )
                   forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ case
        Left HpackError
err -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (Path Abs File -> String -> PantryException
HpackLibraryException Path Abs File
hpackFile forall a b. (a -> b) -> a -> b
$ ProgramName -> HpackError -> String
formatHpackError (forall a. a -> Maybe a -> a
fromMaybe ProgramName
"hpack" Maybe ProgramName
progName) HpackError
err)
        Right Result
r -> do
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Result -> [String]
Hpack.resultWarnings Result
r) (forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString)
          let cabalFile :: Utf8Builder
cabalFile = forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> String
Hpack.resultCabalFile forall a b. (a -> b) -> a -> b
$ Result
r
          case Result -> Status
Hpack.resultStatus Result
r of
            Status
Hpack.Generated -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$
                 Utf8Builder
"Hpack generated a modified version of "
              forall a. Semigroup a => a -> a -> a
<> Utf8Builder
cabalFile
            Status
Hpack.OutputUnchanged ->
              forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Hpack output unchanged in " forall a. Semigroup a => a -> a -> a
<> Utf8Builder
cabalFile
            Status
Hpack.AlreadyGeneratedByNewerHpack -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$
                 Utf8Builder
cabalFile
              forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" was generated with a newer version of Hpack. Ignoring "
              forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (forall b t. Path b t -> String
toFilePath Path Abs File
hpackFile)
              forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" in favor of the Cabal file.\n"
              forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Either please upgrade and try again or, if you want to use the "
              forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (forall b t. Path b t -> String
toFilePath (forall b. Path b File -> Path Rel File
filename Path Abs File
hpackFile))
              forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" file instead of the Cabal file,\n"
              forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"then please delete the Cabal file."
            Status
Hpack.ExistingCabalFileWasModifiedManually -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$
                 Utf8Builder
cabalFile
              forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" was modified manually. Ignoring "
              forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (forall b t. Path b t -> String
toFilePath Path Abs File
hpackFile)
              forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" in favor of the Cabal file.\n"
              forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"If you want to use the "
              forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (forall b t. Path b t -> String
toFilePath (forall b. Path b File -> Path Rel File
filename Path Abs File
hpackFile))
              forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" file instead of the Cabal file,\n"
              forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"then please delete the Cabal file."
      HpackCommand String
command -> forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
catchAny
        ( forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
String -> m a -> m a
withWorkingDir (forall b t. Path b t -> String
toFilePath Path Abs Dir
pkgDir) forall a b. (a -> b) -> a -> b
$
          forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
String -> [String] -> (ProcessConfig () () () -> m a) -> m a
proc String
command [] forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_
        )
        ( forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Path Abs Dir -> SomeException -> PantryException
HpackExeException String
command Path Abs Dir
pkgDir)

-- | Get the 'PackageIdentifier' from a 'GenericPackageDescription'.

--

-- @since 0.1.0.0

gpdPackageIdentifier :: GenericPackageDescription -> PackageIdentifier
gpdPackageIdentifier :: GenericPackageDescription -> PackageIdentifier
gpdPackageIdentifier = PackageDescription -> PackageIdentifier
D.package 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 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 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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageLocationImmutable -> RIO env ByteString
loadCabalFileBytes (PLIHackage PackageIdentifier
pident BlobKey
cfHash TreeKey
_mtree) =
  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 <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageLocationImmutable -> RIO env Package
loadPackage PackageLocationImmutable
pl
  let sfp :: SafeFilePath
sfp = PackageName -> SafeFilePath
cabalFileName forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> PackageName
pkgName forall a b. (a -> b) -> a -> b
$ Package -> PackageIdentifier
packageIdent Package
package
  BlobKey
cabalBlobKey <- case Package -> PackageCabal
packageCabalEntry Package
package of
                       PCHpack PHpack
pcHpack -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ TreeEntry -> BlobKey
teBlob forall b c a. (b -> c) -> (a -> b) -> a -> c
. PHpack -> TreeEntry
phGenerated forall a b. (a -> b) -> a -> b
$ PHpack
pcHpack
                       PCCabalFile (TreeEntry BlobKey
blobKey FileType
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure BlobKey
blobKey
  Maybe ByteString
mbs <- forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage forall a b. (a -> b) -> a -> b
$ forall env.
HasLogFunc env =>
BlobKey -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
loadBlob BlobKey
cabalBlobKey
  case Maybe ByteString
mbs of
    Maybe ByteString
Nothing -> do
      forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable
-> SafeFilePath -> BlobKey -> PantryException
TreeReferencesMissingBlob (PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI PackageLocationImmutable
pl) SafeFilePath
sfp BlobKey
cabalBlobKey
    Just ByteString
bs -> 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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env ByteString
loadRawCabalFileBytes (RPLIHackage PackageIdentifierRevision
pir Maybe TreeKey
_mtree) = forall env.
(HasPantryConfig env, HasLogFunc env) =>
PackageIdentifierRevision -> RIO env ByteString
getHackageCabalFile PackageIdentifierRevision
pir

loadRawCabalFileBytes RawPackageLocationImmutable
pl = do
  Package
package <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env Package
loadPackageRaw RawPackageLocationImmutable
pl
  let sfp :: SafeFilePath
sfp = PackageName -> SafeFilePath
cabalFileName forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> PackageName
pkgName 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 <- forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage forall a b. (a -> b) -> a -> b
$ forall env.
HasLogFunc env =>
BlobKey -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
loadBlob BlobKey
cabalBlobKey
  case Maybe ByteString
mbs of
    Maybe ByteString
Nothing -> do
      forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable
-> SafeFilePath -> BlobKey -> PantryException
TreeReferencesMissingBlob RawPackageLocationImmutable
pl SafeFilePath
sfp BlobKey
cabalBlobKey
    Just ByteString
bs -> 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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageLocationImmutable -> RIO env Package
loadPackage = forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env Package
loadPackageRaw 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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env Package
loadPackageRaw RawPackageLocationImmutable
rpli = do
  case RawPackageLocationImmutable -> Maybe TreeKey
getRawTreeKey RawPackageLocationImmutable
rpli of
    Just TreeKey
treeKey' -> do
      Maybe Package
mpackage <- forall env.
(HasLogFunc env, HasPantryConfig env, HasProcessContext env) =>
RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
tryLoadPackageRawViaDbOrCasa RawPackageLocationImmutable
rpli TreeKey
treeKey'
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe RIO env Package
loadPackageRawViaThirdParty forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Package
mpackage
    Maybe TreeKey
Nothing -> RIO env Package
loadPackageRawViaThirdParty
 where
  loadPackageRawViaThirdParty :: RIO env Package
loadPackageRawViaThirdParty = do
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Loading package from third-party: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
rpli)
    case RawPackageLocationImmutable
rpli of
      RPLIHackage PackageIdentifierRevision
pir Maybe TreeKey
mtree -> HackageTarballResult -> Package
htrPackage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 -> 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 -> 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 :: forall env.
(HasLogFunc env, HasPantryConfig env, HasProcessContext env) =>
RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
tryLoadPackageRawViaDbOrCasa RawPackageLocationImmutable
rpli TreeKey
treeKey' = do
  Maybe Package
mviaDb <- 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
      forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Loaded package from Pantry: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
rpli)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just Package
package)
    Maybe Package
Nothing -> do
      Maybe (CasaRepoPrefix, Int)
mCasaConfig <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig -> Maybe (CasaRepoPrefix, Int)
pcCasaConfig
      case Maybe (CasaRepoPrefix, Int)
mCasaConfig of
        Maybe (CasaRepoPrefix, Int)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        Just (CasaRepoPrefix, Int)
_ -> do
          Maybe Package
mviaCasa <- 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
              forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Loaded package from Casa: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
rpli)
              forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just Package
package)
            Maybe Package
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 :: forall env.
(HasLogFunc env, HasPantryConfig env, HasProcessContext env) =>
RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
tryLoadPackageRawViaCasa RawPackageLocationImmutable
rlpi TreeKey
treeKey' = do
  Maybe (TreeKey, Tree)
mtreePair <- 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    Just (TreeKey
treeKey'', Tree
_tree) -> do
      forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
[RawPackageLocationImmutable] -> RIO env ()
fetchTreeKeys [RawPackageLocationImmutable
rlpi]
      Maybe Package
mdb <- 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
          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: " forall a. Semigroup a => a -> a -> a
<>
             forall a. Display a => a -> Utf8Builder
display TreeKey
treeKey'' forall a. Semigroup a => a -> a -> a
<>
             Utf8Builder
" (for " forall a. Semigroup a => a -> a -> a
<>
             forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
rlpi forall a. Semigroup a => a -> a -> a
<>
             Utf8Builder
")")
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        Just Package
package -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 :: forall env.
(HasLogFunc env, HasPantryConfig env, HasProcessContext env) =>
RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
tryLoadPackageRawViaLocalDb RawPackageLocationImmutable
rlpi TreeKey
treeKey' = do
  Maybe (Entity Tree)
mtreeEntity <- forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (forall env.
TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
getTreeForKey TreeKey
treeKey')
  case Maybe (Entity Tree)
mtreeEntity of
    Maybe (Entity Tree)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    Just Entity Tree
treeId ->
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just (forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> TreeId -> ReaderT SqlBackend (RIO env) Package
loadPackageById RawPackageLocationImmutable
rlpi (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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env CompletePackageLocation
completePackageLocation (RPLIHackage (PackageIdentifierRevision PackageName
n Version
v (CFIHash SHA256
sha (Just FileSize
size))) (Just TreeKey
tk)) =
  forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Completing package location information from " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display PackageIdentifierRevision
pir0
  (PackageIdentifierRevision
pir, BlobKey
cfKey) <-
    case CabalFileInfo
cfi0 of
      CFIHash SHA256
sha (Just FileSize
size) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageIdentifierRevision
pir0, SHA256 -> FileSize -> BlobKey
BlobKey SHA256
sha FileSize
size)
      CabalFileInfo
_ -> do
        ByteString
bs <- forall env.
(HasPantryConfig env, HasLogFunc env) =>
PackageIdentifierRevision -> RIO env ByteString
getHackageCabalFile PackageIdentifierRevision
pir0
        let size :: FileSize
size = Word -> FileSize
FileSize (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 (forall a. a -> Maybe a
Just FileSize
size)
            pir :: PackageIdentifierRevision
pir = PackageName
-> Version -> CabalFileInfo -> PackageIdentifierRevision
PackageIdentifierRevision PackageName
name Version
version CabalFileInfo
cfi
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Added in cabal file hash: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display PackageIdentifierRevision
pir
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageIdentifierRevision
pir, SHA256 -> FileSize -> BlobKey
BlobKey SHA256
sha FileSize
size)
  TreeKey
treeKey' <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageIdentifierRevision -> RIO env TreeKey
getHackageTarballKey PackageIdentifierRevision
pir
  forall (f :: * -> *) a. Applicative f => a -> f a
pure 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' -> forall env.
(HasLogFunc env, HasPantryConfig env, HasProcessContext env) =>
RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
tryLoadPackageRawViaDbOrCasa RawPackageLocationImmutable
pl TreeKey
treeKey'
      Maybe TreeKey
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
  case (,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawArchive -> Maybe SHA256
raHash RawArchive
archive forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RawArchive -> Maybe FileSize
raSize RawArchive
archive 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
      forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 -> forall {env}.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Bool -> RIO env CompletePackageLocation
byThirdParty (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) <- 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
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
warnAboutMissingSizeSha (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
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (RawPackageLocationImmutable
pl, SHA256
sha, FileSize
size, Package
package)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 =
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn
      (forall a. Monoid a => [a] -> a
mconcat
         [ Utf8Builder
"The package "
         , 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: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display a
size
         , Utf8Builder
"\nsha256: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display a
sha
         ])
completePackageLocation pl :: RawPackageLocationImmutable
pl@(RPLIRepo Repo
repo RawPackageMetadata
rpm) = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
isSHA1 (Repo -> Text
repoCommit Repo
repo)) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Repo -> PantryException
CannotCompleteRepoNonSHA1 Repo
repo
  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 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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
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
      forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 <- 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 forall a. Eq a => a -> a -> Bool
== a
y
          isSame a
_ Maybe a
_ = Bool
True

          allSame :: Bool
allSame =
            forall {a}. Eq a => a -> Maybe a -> Bool
isSame (PackageIdentifier -> PackageName
pkgName forall a b. (a -> b) -> a -> b
$ PackageMetadata -> PackageIdentifier
pmIdent PackageMetadata
pm) (RawPackageMetadata -> Maybe PackageName
rpmName RawPackageMetadata
rpm) Bool -> Bool -> Bool
&&
            forall {a}. Eq a => a -> Maybe a -> Bool
isSame (PackageIdentifier -> Version
pkgVersion forall a b. (a -> b) -> a -> b
$ PackageMetadata -> PackageIdentifier
pmIdent PackageMetadata
pm) (RawPackageMetadata -> Maybe Version
rpmVersion RawPackageMetadata
rpm) Bool -> Bool -> 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 forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO 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
  { 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 :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawSnapshotLocation -> RIO env SnapshotLocation
completeSnapshotLocation (RSLCompiler WantedCompiler
c) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ WantedCompiler -> SnapshotLocation
SLCompiler WantedCompiler
c
completeSnapshotLocation (RSLFilePath ResolvedPath File
f) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ResolvedPath File -> SnapshotLocation
SLFilePath ResolvedPath File
f
completeSnapshotLocation (RSLUrl Text
url (Just BlobKey
blobKey)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 <- forall env.
(HasPantryConfig env, HasLogFunc env) =>
Text -> Maybe BlobKey -> RIO env ByteString
loadFromURL Text
url forall a. Maybe a
Nothing
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> BlobKey -> SnapshotLocation
SLUrl Text
url (ByteString -> BlobKey
bsToBlobKey ByteString
bs)
completeSnapshotLocation (RSLSynonym SnapName
syn) =
  forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawSnapshotLocation -> RIO env SnapshotLocation
completeSnapshotLocation forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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_ :: forall (f :: * -> *) env a.
(Foldable f, HasPantryConfig env) =>
(a -> RIO env ()) -> f a -> RIO env ()
traverseConcurrently_ a -> RIO env ()
f f a
t0 = do
  Int
cnt <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig -> Int
pcConnectionCount
  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_ :: forall (m :: * -> *) (f :: * -> *) a.
(MonadUnliftIO m, Foldable f) =>
Int -> (a -> m ()) -> f a -> m ()
traverseConcurrentlyWith_ Int
count a -> m ()
f f a
t0 = do
  TVar [a]
queue <- forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f a
t0

  forall (m :: * -> *) a.
(Applicative m, MonadUnliftIO m) =>
Int -> m a -> m ()
replicateConcurrently_ Int
count forall a b. (a -> b) -> a -> b
$
    forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \m ()
loop -> forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
      [a]
toProcess <- forall a. TVar a -> STM a
readTVar TVar [a]
queue
      case [a]
toProcess of
        [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
        (a
x:[a]
rest) -> do
          forall a. TVar a -> a -> STM ()
writeTVar TVar [a]
queue [a]
rest
          forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawSnapshotLocation -> RIO env RawSnapshot
loadSnapshotRaw RawSnapshotLocation
loc = do
  Either WantedCompiler (RawSnapshotLayer, CompletedSL)
eres <- 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 ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshot
        { rsCompiler :: WantedCompiler
rsCompiler = WantedCompiler
wc
        , rsPackages :: Map PackageName RawSnapshotPackage
rsPackages = forall a. Monoid a => a
mempty
        , rsDrop :: Set PackageName
rsDrop = forall a. Monoid a => a
mempty
        }
    Right (RawSnapshotLayer
rsl, CompletedSL
_) -> do
      RawSnapshot
snap0 <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawSnapshotLocation -> RIO env RawSnapshot
loadSnapshotRaw forall a b. (a -> b) -> a -> b
$ RawSnapshotLayer -> RawSnapshotLocation
rslParent RawSnapshotLayer
rsl
      (Map PackageName RawSnapshotPackage
packages, AddPackagesConfig
unused) <-
        forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Utf8Builder
-> [RawPackageLocationImmutable]
-> AddPackagesConfig
-> Map PackageName RawSnapshotPackage
-> RIO env (Map PackageName RawSnapshotPackage, AddPackagesConfig)
addPackagesToSnapshot
          (forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
loc)
          (RawSnapshotLayer -> [RawPackageLocationImmutable]
rslLocations RawSnapshotLayer
rsl)
          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)
      forall env.
HasLogFunc env =>
Utf8Builder -> AddPackagesConfig -> RIO env ()
warnUnusedAddPackagesConfig (forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
loc) AddPackagesConfig
unused
      forall (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshot
        { rsCompiler :: WantedCompiler
rsCompiler = 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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
SnapshotLocation -> RIO env RawSnapshot
loadSnapshot SnapshotLocation
loc = do
  Either WantedCompiler RawSnapshotLayer
eres <- forall env.
(HasPantryConfig env, HasLogFunc env) =>
SnapshotLocation
-> RIO env (Either WantedCompiler RawSnapshotLayer)
loadSnapshotLayer SnapshotLocation
loc
  case Either WantedCompiler RawSnapshotLayer
eres of
    Left WantedCompiler
wc ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshot
        { rsCompiler :: WantedCompiler
rsCompiler = WantedCompiler
wc
        , rsPackages :: Map PackageName RawSnapshotPackage
rsPackages = forall a. Monoid a => a
mempty
        , rsDrop :: Set PackageName
rsDrop = forall a. Monoid a => a
mempty
        }
    Right RawSnapshotLayer
rsl -> do
      RawSnapshot
snap0 <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawSnapshotLocation -> RIO env RawSnapshot
loadSnapshotRaw forall a b. (a -> b) -> a -> b
$ RawSnapshotLayer -> RawSnapshotLocation
rslParent RawSnapshotLayer
rsl
      (Map PackageName RawSnapshotPackage
packages, AddPackagesConfig
unused) <-
        forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Utf8Builder
-> [RawPackageLocationImmutable]
-> AddPackagesConfig
-> Map PackageName RawSnapshotPackage
-> RIO env (Map PackageName RawSnapshotPackage, AddPackagesConfig)
addPackagesToSnapshot
          (forall a. Display a => a -> Utf8Builder
display SnapshotLocation
loc)
          (RawSnapshotLayer -> [RawPackageLocationImmutable]
rslLocations RawSnapshotLayer
rsl)
          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)
      forall env.
HasLogFunc env =>
Utf8Builder -> AddPackagesConfig -> RIO env ()
warnUnusedAddPackagesConfig (forall a. Display a => a -> Utf8Builder
display SnapshotLocation
loc) AddPackagesConfig
unused
      forall (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshot
        { rsCompiler :: WantedCompiler
rsCompiler = 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. Debug output will include the raw snapshot

-- layer.

--

-- @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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
SnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshot = forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Bool
-> SnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshot' Bool
True

-- | As for 'loadAndCompleteSnapshot' but allows toggling of the debug output of

-- the raw snapshot layer.

--

-- @since 0.5.7

loadAndCompleteSnapshot' ::
     (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => Bool -- ^ Debug output includes the raw snapshot layer

  -> SnapshotLocation
  -> Map RawSnapshotLocation SnapshotLocation
     -- ^ Cached snapshot locations from lock file

  -> Map RawPackageLocationImmutable PackageLocationImmutable
     -- ^ Cached locations from lock file

  -> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshot' :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Bool
-> SnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshot' Bool
debugRSL SnapshotLocation
loc =
  forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Bool
-> RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshotRaw' Bool
debugRSL (SnapshotLocation -> RawSnapshotLocation
toRawSL SnapshotLocation
loc)

-- | Parse a 'Snapshot' (all layers) from a 'RawSnapshotLocation' completing

-- any incomplete package locations. Debug output will include the raw snapshot

-- layer.

--

-- @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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshotRaw = forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Bool
-> RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshotRaw' Bool
True

-- | As for 'loadAndCompleteSnapshotRaw' but allows toggling of the debug output

-- of the raw snapshot layer.

--

-- @since 0.5.7

loadAndCompleteSnapshotRaw' ::
     (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => Bool -- ^ Debug output includes the raw snapshot layer

  -> RawSnapshotLocation
  -> Map RawSnapshotLocation SnapshotLocation
     -- ^ Cached snapshot locations from lock file

  -> Map RawPackageLocationImmutable PackageLocationImmutable
     -- ^ Cached locations from lock file

  -> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshotRaw' :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Bool
-> RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshotRaw' Bool
debugRSL RawSnapshotLocation
rawLoc Map RawSnapshotLocation SnapshotLocation
cacheSL Map RawPackageLocationImmutable PackageLocationImmutable
cachePL = do
  Either WantedCompiler (RawSnapshotLayer, CompletedSL)
eres <- case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RawSnapshotLocation
rawLoc Map RawSnapshotLocation SnapshotLocation
cacheSL of
    Just SnapshotLocation
loc -> forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right (, RawSnapshotLocation -> SnapshotLocation -> CompletedSL
CompletedSL RawSnapshotLocation
rawLoc SnapshotLocation
loc) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env.
(HasPantryConfig env, HasLogFunc env) =>
SnapshotLocation
-> RIO env (Either WantedCompiler RawSnapshotLayer)
loadSnapshotLayer SnapshotLocation
loc
    Maybe SnapshotLocation
Nothing -> 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
            { snapshotCompiler :: WantedCompiler
snapshotCompiler = WantedCompiler
wc
            , snapshotPackages :: Map PackageName SnapshotPackage
snapshotPackages = forall a. Monoid a => a
mempty
            , snapshotDrop :: Set PackageName
snapshotDrop = forall a. Monoid a => a
mempty
            }
      in 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) <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Bool
-> RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshotRaw' Bool
debugRSL (RawSnapshotLayer -> RawSnapshotLocation
rslParent RawSnapshotLayer
rsl) Map RawSnapshotLocation SnapshotLocation
cacheSL Map RawPackageLocationImmutable PackageLocationImmutable
cachePL
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugRSL forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show RawSnapshotLayer
rsl
      (Map PackageName SnapshotPackage
packages, [CompletedPLI]
completed, AddPackagesConfig
unused) <-
        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
            { 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)
      forall env.
HasLogFunc env =>
Utf8Builder -> AddPackagesConfig -> RIO env ()
warnUnusedAddPackagesConfig (forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
rawLoc) AddPackagesConfig
unused
      let snapshot :: Snapshot
snapshot = Snapshot
            { snapshotCompiler :: WantedCompiler
snapshotCompiler = 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
            }
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (Snapshot
snapshot, CompletedSL
sloc forall a. a -> [a] -> [a]
: [CompletedSL]
slocs,[CompletedPLI]
completed0 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 = forall a. a -> a -> ([a] -> [a]) -> SingleOrNot a
Multiple a
a a
b forall a. a -> a
id
  Single a
a <> Multiple a
b a
c [a] -> [a]
d = forall a. a -> a -> ([a] -> [a]) -> SingleOrNot a
Multiple a
a a
b ((a
cforall 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 = forall a. a -> a -> ([a] -> [a]) -> SingleOrNot a
Multiple a
a a
b ([a] -> [a]
c forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
dforall a. a -> [a] -> [a]
:))
  Multiple a
a a
b [a] -> [a]
c <> Multiple a
d a
e [a] -> [a]
f =
    forall a. a -> a -> ([a] -> [a]) -> SingleOrNot a
Multiple a
a a
b ([a] -> [a]
c forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
dforall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
eforall 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 :: forall k a. (k, SingleOrNot a) -> Either (k, a) (k, [a])
sonToEither (k
k, Single a
a) = forall a b. a -> Either a b
Left (k
k, a
a)
sonToEither (k
k, Multiple a
a a
b [a] -> [a]
c) = forall a b. b -> Either a b
Right (k
k, a
a forall a. a -> [a] -> [a]
: a
b 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 :: forall env.
HasLogFunc env =>
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
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Utf8Builder]
ls) forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Some warnings discovered when adding packages to snapshot (" forall a. Semigroup a => a -> a -> a
<> Utf8Builder
source forall a. Semigroup a => a -> a -> a
<> Utf8Builder
")"
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn [Utf8Builder]
ls
 where
  ls :: [Utf8Builder]
ls = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Utf8Builder]
flags', [Utf8Builder]
hiddens', [Utf8Builder]
options']

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

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

  options' :: [Utf8Builder]
options' =
    forall a b. (a -> b) -> [a] -> [b]
map
      (\PackageName
pn ->
        Utf8Builder
"Setting options for nonexistent package: " forall a. Semigroup a => a -> a -> a
<>
        forall a. IsString a => String -> a
fromString (PackageName -> String
packageNameString PackageName
pn))
      (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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
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' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [RawPackageLocationImmutable]
newPackages forall a b. (a -> b) -> a -> b
$ \RawPackageLocationImmutable
loc -> do
    PackageName
name <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env PackageName
getPackageLocationName RawPackageLocationImmutable
loc
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageName
name, RawSnapshotPackage
      { rspLocation :: RawPackageLocationImmutable
rspLocation = RawPackageLocationImmutable
loc
      , rspFlags :: Map FlagName Bool
rspFlags = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault forall a. Monoid a => a
mempty PackageName
name Map PackageName (Map FlagName Bool)
flags
      , rspHidden :: Bool
rspHidden = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Bool
False PackageName
name Map PackageName Bool
hiddens
      , rspGhcOptions :: [Text]
rspGhcOptions = 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)
        = forall a b. [Either a b] -> ([a], [b])
partitionEithers
        forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall k a. (k, SingleOrNot a) -> Either (k, a) (k, [a])
sonToEither
        forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList
        forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. Semigroup a => a -> a -> a
(<>)
        forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall a. a -> SingleOrNot a
Single) [(PackageName, RawSnapshotPackage)]
new'
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PackageName, [RawSnapshotPackage])]
newMultiples) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$
    Utf8Builder
-> [(PackageName, [RawPackageLocationImmutable])]
-> PantryException
DuplicatePackageNames Utf8Builder
source forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a b. (a -> b) -> [a] -> [b]
map RawSnapshotPackage -> RawPackageLocationImmutable
rspLocation)) [(PackageName, [RawSnapshotPackage])]
newMultiples
  let new :: Map PackageName RawSnapshotPackage
new = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PackageName, RawSnapshotPackage)]
newSingles
      allPackages0 :: Map PackageName RawSnapshotPackage
allPackages0 = Map PackageName RawSnapshotPackage
new forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` (Map PackageName RawSnapshotPackage
old forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (forall a b. a -> b -> a
const ()) Set PackageName
drops)
      allPackages :: Map PackageName RawSnapshotPackage
allPackages = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey Map PackageName RawSnapshotPackage
allPackages0 forall a b. (a -> b) -> a -> b
$ \PackageName
name RawSnapshotPackage
rsp ->
        RawSnapshotPackage
rsp
          { rspFlags :: Map FlagName Bool
rspFlags = 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 = 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 = 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 forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` forall k a. Map k a -> Set k
Map.keysSet Map PackageName RawSnapshotPackage
old)
        (Map PackageName (Map FlagName Bool)
flags 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 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 forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` Map PackageName RawSnapshotPackage
allPackages)

  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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Map RawPackageLocationImmutable PackageLocationImmutable
-> RawPackageLocationImmutable
-> RIO env (Maybe PackageLocationImmutable)
cachedSnapshotCompletePackageLocation Map RawPackageLocationImmutable PackageLocationImmutable
cachePackages RawPackageLocationImmutable
rpli = do
  let xs :: Maybe PackageLocationImmutable
xs = 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 <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env CompletePackageLocation
completePackageLocation RawPackageLocationImmutable
rpli
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if CompletePackageLocation -> Bool
cplHasCabalFile CompletePackageLocation
cpl then forall a. a -> Maybe a
Just (CompletePackageLocation -> PackageLocationImmutable
cplComplete CompletePackageLocation
cpl) else forall a. Maybe a
Nothing
    Just PackageLocationImmutable
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 :: 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
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 = 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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
([(PackageName, SnapshotPackage)], [CompletedPLI])
-> RawPackageLocationImmutable
-> RIO env ([(PackageName, SnapshotPackage)], [CompletedPLI])
addPackage ([(PackageName, SnapshotPackage)]
ps, [CompletedPLI]
completed) RawPackageLocationImmutable
rawLoc = do
        Maybe PackageLocationImmutable
mcomplLoc <- 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
            forall env.
HasLogFunc env =>
RawPackageLocationImmutable -> RIO env ()
warnMissingCabalFile RawPackageLocationImmutable
rawLoc
            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
                  { spLocation :: PackageLocationImmutable
spLocation = PackageLocationImmutable
complLoc
                  , spFlags :: Map FlagName Bool
spFlags = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault forall a. Monoid a => a
mempty PackageName
name Map PackageName (Map FlagName Bool)
flags
                  , spHidden :: Bool
spHidden = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Bool
False PackageName
name Map PackageName Bool
hiddens
                  , spGhcOptions :: [Text]
spGhcOptions = 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 forall a. Eq a => a -> a -> Bool
== RawPackageLocationImmutable
rawLoc
                             then [CompletedPLI]
completed
                             else RawPackageLocationImmutable
-> PackageLocationImmutable -> CompletedPLI
CompletedPLI RawPackageLocationImmutable
rawLoc PackageLocationImmutable
complLocforall a. a -> [a] -> [a]
:[CompletedPLI]
completed
            forall (f :: * -> *) a. Applicative f => a -> f a
pure ((PackageName, SnapshotPackage)
pforall a. a -> [a] -> [a]
:[(PackageName, SnapshotPackage)]
ps, [CompletedPLI]
completed')
  ([(PackageName, SnapshotPackage)]
revNew, [CompletedPLI]
revCompleted) <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM 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)
        = forall a b. [Either a b] -> ([a], [b])
partitionEithers
        forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall k a. (k, SingleOrNot a) -> Either (k, a) (k, [a])
sonToEither
        forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList
        forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. Semigroup a => a -> a -> a
(<>)
        forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall a. a -> SingleOrNot a
Single) (forall a. [a] -> [a]
reverse [(PackageName, SnapshotPackage)]
revNew)
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PackageName, [SnapshotPackage])]
newMultiples) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$
    Utf8Builder
-> [(PackageName, [RawPackageLocationImmutable])]
-> PantryException
DuplicatePackageNames Utf8Builder
source forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a b. (a -> b) -> [a] -> [b]
map (PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapshotPackage -> PackageLocationImmutable
spLocation))) [(PackageName, [SnapshotPackage])]
newMultiples
  let new :: Map PackageName SnapshotPackage
new = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PackageName, SnapshotPackage)]
newSingles
      allPackages0 :: Map PackageName SnapshotPackage
allPackages0 = Map PackageName SnapshotPackage
new forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` (Map PackageName SnapshotPackage
old forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (forall a b. a -> b -> a
const ()) Set PackageName
drops)
      allPackages :: Map PackageName SnapshotPackage
allPackages = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey Map PackageName SnapshotPackage
allPackages0 forall a b. (a -> b) -> a -> b
$ \PackageName
name SnapshotPackage
sp ->
        SnapshotPackage
sp
          { spFlags :: Map FlagName Bool
spFlags = 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 = 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 = 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 forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` forall k a. Map k a -> Set k
Map.keysSet Map PackageName SnapshotPackage
old)
        (Map PackageName (Map FlagName Bool)
flags 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 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 forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` Map PackageName SnapshotPackage
allPackages)

  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PackageName SnapshotPackage
allPackages, 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 :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawSnapshotLocation
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
loadRawSnapshotLayer (RSLCompiler WantedCompiler
compiler) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left WantedCompiler
compiler
loadRawSnapshotLayer rsl :: RawSnapshotLocation
rsl@(RSLUrl Text
url Maybe BlobKey
blob) =
  forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny (forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSnapshotLocation -> SomeException -> PantryException
InvalidSnapshot RawSnapshotLocation
rsl) forall a b. (a -> b) -> a -> b
$ do
    ByteString
bs <- forall env.
(HasPantryConfig env, HasLogFunc env) =>
Text -> Maybe BlobKey -> RIO env ByteString
loadFromURL Text
url Maybe BlobKey
blob
    Value
value <- forall (m :: * -> *) a.
(MonadThrow m, FromJSON a) =>
ByteString -> m a
Yaml.decodeThrow ByteString
bs
    RawSnapshotLayer
snapshot <- forall env.
HasLogFunc env =>
RawSnapshotLocation
-> Value -> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
warningsParserHelperRaw RawSnapshotLocation
rsl Value
value forall a. Maybe a
Nothing
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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) =
  forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny (forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSnapshotLocation -> SomeException -> PantryException
InvalidSnapshot RawSnapshotLocation
rsl) forall a b. (a -> b) -> a -> b
$ do
    Value
value <- forall (m :: * -> *) a. (MonadIO m, FromJSON a) => String -> m a
Yaml.decodeFileThrow forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> String
toFilePath forall a b. (a -> b) -> a -> b
$ forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath File
fp
    RawSnapshotLayer
snapshot <- forall env.
HasLogFunc env =>
RawSnapshotLocation
-> Value -> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
warningsParserHelperRaw RawSnapshotLocation
rsl Value
value forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> Path b Dir
parent forall a b. (a -> b) -> a -> b
$ forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath File
fp
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 <- forall env.
HasPantryConfig env =>
SnapName -> RIO env RawSnapshotLocation
snapshotLocation SnapName
syn
  Either WantedCompiler (RawSnapshotLayer, CompletedSL)
comp <- forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawSnapshotLocation
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
loadRawSnapshotLayer RawSnapshotLocation
loc
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Either WantedCompiler (RawSnapshotLayer, CompletedSL)
comp of
    Left WantedCompiler
wc -> forall a b. a -> Either a b
Left WantedCompiler
wc
    Right (RawSnapshotLayer
l, CompletedSL RawSnapshotLocation
_ SnapshotLocation
n) -> 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 :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
SnapshotLocation
-> RIO env (Either WantedCompiler RawSnapshotLayer)
loadSnapshotLayer (SLCompiler WantedCompiler
compiler) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left WantedCompiler
compiler
loadSnapshotLayer sl :: SnapshotLocation
sl@(SLUrl Text
url BlobKey
blob) =
  forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny (forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSnapshotLocation -> SomeException -> PantryException
InvalidSnapshot (SnapshotLocation -> RawSnapshotLocation
toRawSL SnapshotLocation
sl)) forall a b. (a -> b) -> a -> b
$ do
    ByteString
bs <- forall env.
(HasPantryConfig env, HasLogFunc env) =>
Text -> Maybe BlobKey -> RIO env ByteString
loadFromURL Text
url (forall a. a -> Maybe a
Just BlobKey
blob)
    Value
value <- forall (m :: * -> *) a.
(MonadThrow m, FromJSON a) =>
ByteString -> m a
Yaml.decodeThrow ByteString
bs
    RawSnapshotLayer
snapshot <- forall env.
HasLogFunc env =>
SnapshotLocation
-> Value -> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
warningsParserHelper SnapshotLocation
sl Value
value forall a. Maybe a
Nothing
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right RawSnapshotLayer
snapshot
loadSnapshotLayer sl :: SnapshotLocation
sl@(SLFilePath ResolvedPath File
fp) =
  forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny (forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSnapshotLocation -> SomeException -> PantryException
InvalidSnapshot (SnapshotLocation -> RawSnapshotLocation
toRawSL SnapshotLocation
sl)) forall a b. (a -> b) -> a -> b
$ do
    Value
value <- forall (m :: * -> *) a. (MonadIO m, FromJSON a) => String -> m a
Yaml.decodeFileThrow forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> String
toFilePath forall a b. (a -> b) -> a -> b
$ forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath File
fp
    RawSnapshotLayer
snapshot <- forall env.
HasLogFunc env =>
SnapshotLocation
-> Value -> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
warningsParserHelper SnapshotLocation
sl Value
value forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> Path b Dir
parent forall a b. (a -> b) -> a -> b
$ forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath File
fp
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right RawSnapshotLayer
snapshot

loadFromURL ::
     (HasPantryConfig env, HasLogFunc env)
  => Text -- ^ url

  -> Maybe BlobKey
  -> RIO env ByteString
loadFromURL :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
Text -> Maybe BlobKey -> RIO env ByteString
loadFromURL Text
url Maybe BlobKey
Nothing = do
  Maybe ByteString
mcached <- forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage forall a b. (a -> b) -> a -> b
$ forall env. Text -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
loadURLBlob Text
url
  case Maybe ByteString
mcached of
    Just ByteString
bs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs
    Maybe ByteString
Nothing -> forall env.
(HasPantryConfig env, HasLogFunc env) =>
Text -> Maybe BlobKey -> RIO env ByteString
loadWithCheck Text
url forall a. Maybe a
Nothing
loadFromURL Text
url (Just BlobKey
bkey) = do
  Maybe ByteString
mcached <- forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage forall a b. (a -> b) -> a -> b
$ forall env.
HasLogFunc env =>
BlobKey -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
loadBlob BlobKey
bkey
  case Maybe ByteString
mcached of
    Just ByteString
bs -> do
      forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Loaded snapshot from Pantry database."
      forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs
    Maybe ByteString
Nothing -> 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 :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
Text -> BlobKey -> RIO env ByteString
loadUrlViaCasaOrWithCheck Text
url BlobKey
blobKey = do
  Maybe ByteString
mblobFromCasa <- forall env.
(HasPantryConfig env, HasLogFunc env) =>
BlobKey -> RIO env (Maybe ByteString)
casaLookupKey BlobKey
blobKey
  case Maybe ByteString
mblobFromCasa of
    Just ByteString
blob -> do
      forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug
        (Utf8Builder
"Loaded snapshot from Casa (" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display BlobKey
blobKey forall a. Semigroup a => a -> a -> a
<> Utf8Builder
") for URL: " forall a. Semigroup a => a -> a -> a
<>
         forall a. Display a => a -> Utf8Builder
display Text
url)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
blob
    Maybe ByteString
Nothing -> forall env.
(HasPantryConfig env, HasLogFunc env) =>
Text -> Maybe BlobKey -> RIO env ByteString
loadWithCheck Text
url (forall a. a -> Maybe a
Just BlobKey
blobKey)

loadWithCheck ::
     (HasPantryConfig env, HasLogFunc env)
  => Text -- ^ url

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

warningsParserHelperRaw ::
     HasLogFunc env
  => RawSnapshotLocation
  -> Value
  -> Maybe (Path Abs Dir)
  -> RIO env RawSnapshotLayer
warningsParserHelperRaw :: forall env.
HasLogFunc env =>
RawSnapshotLocation
-> Value -> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
warningsParserHelperRaw RawSnapshotLocation
rsl Value
val Maybe (Path Abs Dir)
mdir =
  case forall a b. (a -> Parser b) -> a -> Either String b
parseEither forall a. FromJSON a => Value -> Parser a
Yaml.parseJSON Value
val of
    Left String
e -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ RawSnapshotLocation -> String -> PantryException
Couldn'tParseSnapshot RawSnapshotLocation
rsl String
e
    Right (WithJSONWarnings Unresolved RawSnapshotLayer
x [JSONWarning]
ws) -> do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [JSONWarning]
ws) forall a b. (a -> b) -> a -> b
$ do
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Warnings when parsing snapshot " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
rsl
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [JSONWarning]
ws forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Utf8Builder
display
      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 :: forall env.
HasLogFunc env =>
SnapshotLocation
-> Value -> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
warningsParserHelper SnapshotLocation
sl Value
val Maybe (Path Abs Dir)
mdir =
  case forall a b. (a -> Parser b) -> a -> Either String b
parseEither forall a. FromJSON a => Value -> Parser a
Yaml.parseJSON Value
val of
    Left String
e -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ RawSnapshotLocation -> String -> PantryException
Couldn'tParseSnapshot (SnapshotLocation -> RawSnapshotLocation
toRawSL SnapshotLocation
sl) String
e
    Right (WithJSONWarnings Unresolved RawSnapshotLayer
x [JSONWarning]
ws) -> do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [JSONWarning]
ws) forall a b. (a -> b) -> a -> b
$ do
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Warnings when parsing snapshot " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display SnapshotLocation
sl
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [JSONWarning]
ws forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Utf8Builder
display
      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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env PackageName
getPackageLocationName = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageIdentifier -> PackageName
pkgName forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env PackageIdentifier
getRawPackageLocationIdent (RPLIHackage (PackageIdentifierRevision PackageName
name Version
version CabalFileInfo
_) Maybe TreeKey
_) =
  forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 }) =
  forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 }) =
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version
getRawPackageLocationIdent RawPackageLocationImmutable
rpli = Package -> PackageIdentifier
packageIdent forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env TreeKey
getRawPackageLocationTreeKey RawPackageLocationImmutable
pl =
  case RawPackageLocationImmutable -> Maybe TreeKey
getRawTreeKey RawPackageLocationImmutable
pl of
    Just TreeKey
treeKey' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TreeKey
treeKey'
    Maybe TreeKey
Nothing ->
      case RawPackageLocationImmutable
pl of
        RPLIHackage PackageIdentifierRevision
pir Maybe TreeKey
_ -> forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageIdentifierRevision -> RIO env TreeKey
getHackageTarballKey PackageIdentifierRevision
pir
        RPLIArchive RawArchive
archive RawPackageMetadata
pm -> 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 -> 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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageLocationImmutable -> RIO env TreeKey
getPackageLocationTreeKey PackageLocationImmutable
pl = forall (f :: * -> *) a. Applicative f => a -> f a
pure 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' or '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 :: Lens' PantryApp SimpleApp
simpleAppL = 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 :: Lens' PantryConfig HpackExecutable
hpackExecutableL HpackExecutable -> f HpackExecutable
k PantryConfig
pconfig =
  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 :: Lens' PantryApp LogFunc
logFuncL = Lens' PantryApp SimpleApp
simpleAppLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasLogFunc env => Lens' env LogFunc
logFuncL

instance HasPantryConfig PantryApp where
  pantryConfigL :: Lens' PantryApp PantryConfig
pantryConfigL = 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 :: Lens' PantryApp ProcessContext
processContextL = Lens' PantryApp SimpleApp
simpleAppLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasProcessContext env => Lens' env ProcessContext
processContextL

instance HasStylesUpdate PantryApp where
  stylesUpdateL :: Lens' PantryApp StylesUpdate
stylesUpdateL = 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 :: Lens' PantryApp Bool
useColorL = 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 :: Lens' PantryApp Int
termWidthL = 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 :: forall (m :: * -> *) a. MonadIO m => RIO PantryApp a -> m a
runPantryApp = 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 :: forall (m :: * -> *) a.
MonadIO m =>
Int -> CasaRepoPrefix -> Int -> RIO PantryApp a -> m a
runPantryAppWith Int
maxConnCount CasaRepoPrefix
casaRepoPrefix Int
casaMaxPerRequest RIO PantryApp a
f = forall (m :: * -> *) a. MonadIO m => RIO SimpleApp a -> m a
runSimpleApp forall a b. (a -> b) -> a -> b
$ do
  SimpleApp
sa <- forall r (m :: * -> *). MonadReader r m => m r
ask
  String
stack <- forall (m :: * -> *). MonadIO m => String -> m String
getAppUserDataDirectory String
"stack"
  Path Abs Dir
root <- forall (m :: * -> *). MonadThrow m => String -> m (Path Abs Dir)
parseAbsDir forall a b. (a -> b) -> a -> b
$ String
stack String -> String -> String
FilePath.</> String
"pantry"
  forall env a.
HasLogFunc env =>
Path Abs Dir
-> PackageIndexConfig
-> HpackExecutable
-> Int
-> Maybe (CasaRepoPrefix, Int)
-> (SnapName -> RawSnapshotLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
withPantryConfig'
    Path Abs Dir
root
    PackageIndexConfig
defaultPackageIndexConfig
    HpackExecutable
HpackBundled
    Int
maxConnCount
    (forall a. a -> Maybe a
Just (CasaRepoPrefix
casaRepoPrefix, Int
casaMaxPerRequest))
    SnapName -> RawSnapshotLocation
defaultSnapshotLocation
    forall a b. (a -> b) -> a -> b
$ \PantryConfig
pc ->
      forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO
        PantryApp
          { paSimpleApp :: SimpleApp
paSimpleApp = SimpleApp
sa
          , paPantryConfig :: PantryConfig
paPantryConfig = PantryConfig
pc
          , paTermWidth :: Int
paTermWidth = Int
100
          , paUseColor :: Bool
paUseColor = Bool
True
          , paStylesUpdate :: StylesUpdate
paStylesUpdate = 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 :: forall (m :: * -> *) a. MonadIO m => RIO PantryApp a -> m a
runPantryAppClean RIO PantryApp a
f =
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> (String -> m a) -> m a
withSystemTempDirectory String
"pantry-clean" forall a b. (a -> b) -> a -> b
$ \String
dir -> forall (m :: * -> *) a. MonadIO m => RIO SimpleApp a -> m a
runSimpleApp forall a b. (a -> b) -> a -> b
$ do
    SimpleApp
sa <- forall r (m :: * -> *). MonadReader r m => m r
ask
    Path Abs Dir
root <- forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
resolveDir' String
dir
    forall env a.
HasLogFunc env =>
Path Abs Dir
-> PackageIndexConfig
-> HpackExecutable
-> Int
-> Maybe (CasaRepoPrefix, Int)
-> (SnapName -> RawSnapshotLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
withPantryConfig'
      Path Abs Dir
root
      PackageIndexConfig
defaultPackageIndexConfig
      HpackExecutable
HpackBundled
      Int
8
      (forall a. a -> Maybe a
Just (CasaRepoPrefix
defaultCasaRepoPrefix, Int
defaultCasaMaxPerRequest))
      SnapName -> RawSnapshotLocation
defaultSnapshotLocation
      forall a b. (a -> b) -> a -> b
$ \PantryConfig
pc ->
        forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO
          PantryApp
            { paSimpleApp :: SimpleApp
paSimpleApp = SimpleApp
sa
            , paPantryConfig :: PantryConfig
paPantryConfig = PantryConfig
pc
            , paTermWidth :: Int
paTermWidth = Int
100
            , paUseColor :: Bool
paUseColor = Bool
True
            , paStylesUpdate :: StylesUpdate
paStylesUpdate = 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 :: forall env.
(HasTerm env, HasPantryConfig env) =>
WantedCompiler -> RIO env (Maybe (Map PackageName Version))
loadGlobalHints WantedCompiler
wc =
    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 <- forall env. HasPantryConfig env => RIO env (Path Abs File)
getGlobalHintsFile
    Request
req <- forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
"https://raw.githubusercontent.com/commercialhaskell/stackage-content/master/stack/global-hints.yaml"
    Bool
downloaded <- 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 <- forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (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 -> forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError
                               ( Utf8Builder
"Error: [S-912]\n"
                                 forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Error when parsing global hints: "
                                 forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow SomeException
e
                               )
        Right Maybe (Map a b)
x -> 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
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$
          Utf8Builder
"Could not find local global hints for " forall a. Semigroup a => a -> a -> a
<>
          forall a. Display a => a -> Utf8Builder
RIO.display WantedCompiler
wc forall a. Semigroup a => a -> a -> a
<>
          Utf8Builder
", forcing a redownload"
        Bool
x <- 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
            forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Redownload didn't happen"
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
      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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
        forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup WantedCompiler
wc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. CabalString a -> a
unCabalString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a v. Map (CabalString a) v -> Map a v
unCabalStringMap)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. (MonadIO m, FromJSON a) => String -> m a
Yaml.decodeFileThrow (forall b t. Path b t -> String
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 :: forall id a.
Ord id =>
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 =
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> s
execState (forall {a}. Map PackageName [a]
replaced, forall a. Monoid a => a
mempty) forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName a
globals) forall a b. (a -> b) -> a -> b
$ 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' = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (a -> id
getId forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a. a -> a
id) (forall k a. Map k a -> [a]
Map.elems Map PackageName a
globals)
  replaced :: Map PackageName [a]
replaced = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (forall a b. a -> b -> a
const []) forall a b. (a -> b) -> a -> b
$ 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 :: 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
pname, a
a)  = do
  (Map PackageName [PackageName]
pruned, Map PackageName a
kept) <- forall s (m :: * -> *). MonadState s m => m s
get
  if forall k a. Ord k => k -> Map k a -> Bool
Map.member PackageName
pname Map PackageName [PackageName]
pruned
  then forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  else if forall k a. Ord k => k -> Map k a -> Bool
Map.member PackageName
pname Map PackageName a
kept
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    else do
      let deps :: [a]
deps = forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map id a
pkgs (forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ a -> [id]
getDeps a
a)
      [PackageName]
prunedDeps <- forall (m :: * -> *) a b.
Monad m =>
[a] -> (a -> m (Maybe b)) -> m [b]
forMaybeM [a]
deps forall a b. (a -> b) -> a -> b
$ \a
dep -> do
        let depName :: PackageName
depName = a -> PackageName
getName a
dep
        Bool
isPruned <- 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)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if Bool
isPruned then forall a. a -> Maybe a
Just PackageName
depName else forall a. Maybe a
Nothing
      if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
prunedDeps
      then do
        forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PackageName
pname a
a)
      else do
        forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PackageName
pname [PackageName]
prunedDeps)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (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 :: forall env a.
(HasPantryConfig env, HasLogFunc env) =>
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 <- forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage forall a b. (a -> b) -> a -> b
$ forall env.
SnapshotCacheHash
-> ReaderT SqlBackend (RIO env) (Maybe SnapshotCacheId)
getSnapshotCacheByHash SnapshotCacheHash
hash
  SnapshotCacheId
cacheId <- case Maybe SnapshotCacheId
mres of
    Maybe SnapshotCacheId
Nothing -> do
      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
      forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage forall a b. (a -> b) -> a -> b
$ do
        SnapshotCacheId
scId <- forall env.
SnapshotCacheHash -> ReaderT SqlBackend (RIO env) SnapshotCacheId
getSnapshotCacheId SnapshotCacheHash
hash
        forall env.
SnapshotCacheId
-> Map PackageName (Set ModuleName)
-> ReaderT SqlBackend (RIO env) ()
storeSnapshotModuleCache SnapshotCacheId
scId Map PackageName (Set ModuleName)
packageModules
        forall (f :: * -> *) a. Applicative f => a -> f a
pure SnapshotCacheId
scId
    Just SnapshotCacheId
scId -> forall (f :: * -> *) a. Applicative f => a -> f a
pure SnapshotCacheId
scId
  (ModuleName -> RIO env [PackageName]) -> RIO env a
f forall a b. (a -> b) -> a -> b
$ forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 =
     forall a. Display a => a -> Utf8Builder
display Int
n
  forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" "
  forall a. Semigroup a => a -> a -> a
<> Utf8Builder
text
  forall a. Semigroup a => a -> a -> a
<> (if Int
n forall a. Eq a => a -> a -> Bool
== Int
1
       then Utf8Builder
""
       else Utf8Builder
"s")