{-# 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
  , defaultGlobalHintsLocation
  , HasPantryConfig (..)
  , withPantryConfig
  , withPantryConfig'
  , HpackExecutable (..)

    -- ** Convenience

  , PantryApp
  , runPantryApp
  , runPantryAppClean
  , runPantryAppWith
  , hpackExecutableL
  , hpackForceL

    -- * Types


    -- ** Exceptions

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

    -- ** Cabal types

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

    -- ** Hpack types

  , Hpack.Force (..)

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

    -- ** Global hints

  , GlobalHintsLocation (..)

    -- * 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 ( (.|), mapC, mapMC, runConduitRes, sinkList, sumC )
import           Control.Applicative ( empty )
import           Control.Arrow ( right )
import           Control.Monad.State.Strict ( State, execState, get, modify' )
import           Control.Monad.Trans.Maybe ( MaybeT (..) )
#if MIN_VERSION_transformers(0,6,0)
import           Control.Monad.Trans.Maybe ( hoistMaybe )
#endif
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.Class.PersistEntity ( 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 ( download, redownload )
import           Pantry.Archive
                   ( fetchArchives, findCabalOrHpackFile, getArchive
                   , getArchiveKey, getArchivePackage
                   )
import           Pantry.Casa ( casaBlobSource, casaLookupKey, casaLookupTree )
import           Pantry.HTTP ( httpSinkChecked, parseRequest )
import           Pantry.Hackage
                   ( DidUpdateOccur (..), RequireHackageIndex (..)
                   , UsePreferredVersions (..), getHackageCabalFile
                   , getHackagePackageVersionRevisions
                   , getHackagePackageVersions, getHackageTarball
                   , getHackageTarballKey, getHackageTypoCorrections
                   , hackageIndexTarballL, htrPackage, updateHackageIndex
                   )
import           Pantry.Repo
                   ( fetchRepos, fetchReposRaw, getRepo, getRepoKey, withRepo )
import qualified Pantry.SHA256 as SHA256
import           Pantry.Storage
                   ( getSnapshotCacheByHash, getSnapshotCacheId, getTreeForKey
                   , initStorage, loadBlob, loadCachedTree
                   , loadExposedModulePackages, loadPackageById, loadURLBlob
                   , storeSnapshotModuleCache, storeTree, storeURLBlob
                   , withStorage
                   )
import           Pantry.Tree ( rawParseGPD, unpackTree )
import           Pantry.Types as P
                   ( Archive (..), ArchiveLocation (..), BlobKey (..)
                   , CabalFileInfo (..), CabalString (..), FileSize (..)
                   , FuzzyResults (..), GlobalHintsLocation (..)
                   , HackageSecurityConfig (..), HasPantryConfig (..)
                   , HpackExecutable (..), Mismatch (..), ModuleName
                   , Package (..), PackageCabal (..), PackageIdentifier (..)
                   , PackageIdentifierRevision (..), PackageIndexConfig (..)
                   , PackageLocation (..), PackageLocationImmutable (..)
                   , PackageMetadata (..), PackageName, PantryConfig (..)
                   , PantryException (..), PHpack (..), PrintWarnings (..)
                   , RawArchive (..), RawPackageLocation (..)
                   , RawPackageLocationImmutable (..), RawPackageMetadata (..)
                   , RawSnapshot (..), RawSnapshotLayer (..)
                   , RawSnapshotLocation (..), RawSnapshotPackage (..)
                   , RelFilePath (..), Repo (..), RepoType (..)
                   , ResolvedPath (..), Revision (..), SafeFilePath, SHA256
                   , SimpleRepo (..), SnapName (..), Snapshot (..)
                   , SnapshotCacheHash (..), SnapshotLayer (..)
                   , SnapshotLocation (..), SnapshotPackage (..), Tree (..)
                   , TreeEntry (..), TreeKey (..), Unresolved, Version
                   , WantedCompiler (..), bsToBlobKey, cabalFileName
                   , defaultGlobalHintsLocation, defaultHackageSecurityConfig
                   , defaultSnapshotLocation, flagNameString, getGlobalHintsFile
                   , globalHintsLocation, mkSafeFilePath, moduleNameString
                   , packageIdentifierString, packageNameString, parseFlagName
                   , parseHackageText, parsePackageIdentifier
                   , parsePackageIdentifierRevision, parsePackageName
                   , parsePackageNameThrowing, parseRawSnapshotLocation
                   , parseSnapName, parseTreeM, parseVersion
                   , parseVersionThrowing, parseWantedCompiler, pirForHash
                   , resolvePaths, snapshotLocation, toCabalStringMap, toRawPL
                   , toRawPLI, toRawPM, toRawSL, toRawSnapshotLayer
                   , unCabalStringMap, unSafeFilePath, versionString
                   , warnMissingCabalFile
                   )
import           Path
                   ( Abs, Dir, File, Path, (</>), filename, parent, parseAbsDir
                   , parseRelFile, toFilePath
                   )
import           Path.IO ( copyFile, 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
                   ( HasTerm (..), blankLine, flow, line, pretty, prettyDebugL
                   , prettyError, prettyInfoL, string
                   )
import           RIO.PrettyPrint.StylesUpdate
                   ( HasStylesUpdate (..), StylesUpdate )
import           RIO.Process
                   ( HasProcessContext (..), proc, runProcess_, withWorkingDir )
import qualified RIO.Set as Set
import           RIO.Text ( unpack )
import qualified RIO.Text as T
import           System.IO.Error ( isDoesNotExistError )

#if !MIN_VERSION_transformers(0,6,0)
-- | Convert a 'Maybe' computation to 'MaybeT'.

hoistMaybe :: (Applicative m) => Maybe b -> MaybeT m b
hoistMaybe = MaybeT . pure
#endif

decodeYaml :: FilePath -> IO (Either String ([String], Value))
decodeYaml :: String -> IO (Either String ([String], Value))
decodeYaml String
file = do
  (ParseException -> String)
-> (([Warning], Value) -> ([String], Value))
-> Either ParseException ([Warning], Value)
-> Either String ([String], Value)
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ParseException -> String
forall e. Exception e => e -> String
displayException (([Warning] -> [String]) -> ([Warning], Value) -> ([String], Value)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [Warning] -> [String]
formatWarnings) (Either ParseException ([Warning], Value)
 -> Either String ([String], Value))
-> IO (Either ParseException ([Warning], Value))
-> IO (Either String ([String], Value))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Either ParseException ([Warning], Value))
forall a.
FromJSON a =>
String -> IO (Either ParseException ([Warning], a))
decodeFileWithWarnings String
file
  where
    formatWarnings :: [Warning] -> [String]
formatWarnings = (Warning -> String) -> [Warning] -> [String]
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"
  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
file
  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":\n\n"
  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ParseException -> String
forall e. Exception e => e -> String
displayException ParseException
e

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

-- Hpack's approach to overwriting Cabal files is configurable and 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

  -> (WantedCompiler -> GlobalHintsLocation)
     -- ^ The location of global hints

  -> (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)
-> (WantedCompiler -> GlobalHintsLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
withPantryConfig Path Abs Dir
root PackageIndexConfig
pic HpackExecutable
he Int
count CasaRepoPrefix
pullURL Int
maxPerRequest =
  Path Abs Dir
-> PackageIndexConfig
-> HpackExecutable
-> Force
-> Int
-> Maybe (CasaRepoPrefix, Int)
-> (SnapName -> RawSnapshotLocation)
-> (WantedCompiler -> GlobalHintsLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
forall env a.
HasLogFunc env =>
Path Abs Dir
-> PackageIndexConfig
-> HpackExecutable
-> Force
-> Int
-> Maybe (CasaRepoPrefix, Int)
-> (SnapName -> RawSnapshotLocation)
-> (WantedCompiler -> GlobalHintsLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
withPantryConfig' Path Abs Dir
root PackageIndexConfig
pic HpackExecutable
he Force
Hpack.NoForce Int
count ((CasaRepoPrefix, Int) -> Maybe (CasaRepoPrefix, Int)
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?

  -> Hpack.Force
     -- ^ Should Hpack force the overwriting of a Cabal file that has been

     -- modified manually?

     --

     -- @since 0.10.0

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

  -> (WantedCompiler -> GlobalHintsLocation)
     -- ^ The location of global hints

  -> (PantryConfig -> RIO env a)
     -- ^ What to do with the config

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

    LogFunc -> RIO LogFunc a -> RIO env a
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO (LogFunc
forall a. Monoid a => a
mempty :: LogFunc) (RIO LogFunc a -> RIO env a) -> RIO LogFunc a -> RIO env a
forall a b. (a -> b) -> a -> b
$ Path Abs File -> (Storage -> RIO LogFunc a) -> RIO LogFunc a
forall env a.
HasLogFunc env =>
Path Abs File -> (Storage -> RIO env a) -> RIO env a
initStorage (Path Abs Dir
root Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
pantryRelFile) ((Storage -> RIO LogFunc a) -> RIO LogFunc a)
-> (Storage -> RIO LogFunc a) -> RIO LogFunc a
forall a b. (a -> b) -> a -> b
$ \Storage
storage -> env -> RIO env a -> RIO LogFunc a
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO env
env (RIO env a -> RIO LogFunc a) -> RIO env a -> RIO LogFunc a
forall a b. (a -> b) -> a -> b
$ do
      MVar Bool
ur <- Bool -> RIO env (MVar Bool)
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar Bool
True
      IORef (Map RawPackageLocationImmutable GenericPackageDescription)
ref1 <- Map RawPackageLocationImmutable GenericPackageDescription
-> RIO
     env
     (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Map RawPackageLocationImmutable GenericPackageDescription
forall a. Monoid a => a
mempty
      IORef
  (Map
     (Path Abs Dir)
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File))
ref2 <- Map
  (Path Abs Dir)
  (PrintWarnings -> IO GenericPackageDescription, PackageName,
   Path Abs File)
-> RIO
     env
     (IORef
        (Map
           (Path Abs Dir)
           (PrintWarnings -> IO GenericPackageDescription, PackageName,
            Path Abs File)))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Map
  (Path Abs Dir)
  (PrintWarnings -> IO GenericPackageDescription, PackageName,
   Path Abs File)
forall a. Monoid a => a
mempty
      PantryConfig -> RIO env a
inner PantryConfig
        { pcPackageIndex :: PackageIndexConfig
pcPackageIndex = PackageIndexConfig
pic
        , pcHpackExecutable :: HpackExecutable
pcHpackExecutable = HpackExecutable
he
        , pcHpackForce :: Force
pcHpackForce = Force
hpackForce
        , 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
        , pcGlobalHintsLocation :: WantedCompiler -> GlobalHintsLocation
pcGlobalHintsLocation = WantedCompiler -> GlobalHintsLocation
globalHintsLoc
        }

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

-- | Returns location of the latest version of the given package available from

-- Hackage.

--

-- @since 0.1.0.0

getLatestHackageLocation ::
     (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => RequireHackageIndex
  -> PackageName -- ^ package name

  -> UsePreferredVersions
  -> RIO env (Maybe PackageLocationImmutable)
getLatestHackageLocation :: 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 <-
    (((Version, Map Revision BlobKey),
  Map Version (Map Revision BlobKey))
 -> (Version, Map Revision BlobKey))
-> Maybe
     ((Version, Map Revision BlobKey),
      Map Version (Map Revision BlobKey))
-> Maybe (Version, Map Revision BlobKey)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Version, Map Revision BlobKey),
 Map Version (Map Revision BlobKey))
-> (Version, Map Revision BlobKey)
forall a b. (a, b) -> a
fst (Maybe
   ((Version, Map Revision BlobKey),
    Map Version (Map Revision BlobKey))
 -> Maybe (Version, Map Revision BlobKey))
-> (Map Version (Map Revision BlobKey)
    -> Maybe
         ((Version, Map Revision BlobKey),
          Map Version (Map Revision BlobKey)))
-> Map Version (Map Revision BlobKey)
-> Maybe (Version, Map Revision BlobKey)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Version (Map Revision BlobKey)
-> Maybe
     ((Version, Map Revision BlobKey),
      Map Version (Map Revision BlobKey))
forall k a. Map k a -> Maybe ((k, a), Map k a)
Map.maxViewWithKey (Map Version (Map Revision BlobKey)
 -> Maybe (Version, Map Revision BlobKey))
-> RIO env (Map Version (Map Revision BlobKey))
-> RIO env (Maybe (Version, Map Revision BlobKey))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RequireHackageIndex
-> UsePreferredVersions
-> PackageName
-> RIO env (Map Version (Map Revision BlobKey))
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RequireHackageIndex
-> UsePreferredVersions
-> PackageName
-> RIO env (Map Version (Map Revision BlobKey))
getHackagePackageVersions RequireHackageIndex
req UsePreferredVersions
preferred PackageName
name
  let mVerCfKey :: Maybe (Version, BlobKey)
mVerCfKey = do
        (Version
version, Map Revision BlobKey
revisions) <- Maybe (Version, Map Revision BlobKey)
mversion
        (Revision
_rev, BlobKey
cfKey) <- ((Revision, BlobKey), Map Revision BlobKey) -> (Revision, BlobKey)
forall a b. (a, b) -> a
fst (((Revision, BlobKey), Map Revision BlobKey)
 -> (Revision, BlobKey))
-> Maybe ((Revision, BlobKey), Map Revision BlobKey)
-> Maybe (Revision, BlobKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Revision BlobKey
-> Maybe ((Revision, BlobKey), Map Revision BlobKey)
forall k a. Map k a -> Maybe ((k, a), Map k a)
Map.maxViewWithKey Map Revision BlobKey
revisions
        (Version, BlobKey) -> Maybe (Version, BlobKey)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Version
version, BlobKey
cfKey)

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

-- | Returns the latest revision of the given package version available from

-- Hackage.

--

-- @since 0.1.0.0

getLatestHackageRevision ::
     (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => RequireHackageIndex
  -> PackageName -- ^ package name

  -> Version
  -> RIO env (Maybe (Revision, BlobKey, TreeKey))
getLatestHackageRevision :: 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 <- RequireHackageIndex
-> PackageName -> Version -> RIO env (Map Revision BlobKey)
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RequireHackageIndex
-> PackageName -> Version -> RIO env (Map Revision BlobKey)
getHackagePackageVersionRevisions RequireHackageIndex
req PackageName
name Version
version
  case ((Revision, BlobKey), Map Revision BlobKey) -> (Revision, BlobKey)
forall a b. (a, b) -> a
fst (((Revision, BlobKey), Map Revision BlobKey)
 -> (Revision, BlobKey))
-> Maybe ((Revision, BlobKey), Map Revision BlobKey)
-> Maybe (Revision, BlobKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Revision BlobKey
-> Maybe ((Revision, BlobKey), Map Revision BlobKey)
forall k a. Map k a -> Maybe ((k, a), Map k a)
Map.maxViewWithKey Map Revision BlobKey
revisions of
    Maybe (Revision, BlobKey)
Nothing -> Maybe (Revision, BlobKey, TreeKey)
-> RIO env (Maybe (Revision, BlobKey, TreeKey))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Revision, BlobKey, TreeKey)
forall a. Maybe a
Nothing
    Just (Revision
revision, cfKey :: BlobKey
cfKey@(BlobKey SHA256
sha FileSize
size)) -> do
      let cfi :: CabalFileInfo
cfi = SHA256 -> Maybe FileSize -> CabalFileInfo
CFIHash SHA256
sha (FileSize -> Maybe FileSize
forall a. a -> Maybe a
Just FileSize
size)
      TreeKey
treeKey' <- PackageIdentifierRevision -> RIO env TreeKey
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageIdentifierRevision -> RIO env TreeKey
getHackageTarballKey (PackageName
-> Version -> CabalFileInfo -> PackageIdentifierRevision
PackageIdentifierRevision PackageName
name Version
version CabalFileInfo
cfi)
      Maybe (Revision, BlobKey, TreeKey)
-> RIO env (Maybe (Revision, BlobKey, TreeKey))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Revision, BlobKey, TreeKey)
 -> RIO env (Maybe (Revision, BlobKey, TreeKey)))
-> Maybe (Revision, BlobKey, TreeKey)
-> RIO env (Maybe (Revision, BlobKey, TreeKey))
forall a b. (a -> b) -> a -> b
$ (Revision, BlobKey, TreeKey) -> Maybe (Revision, BlobKey, TreeKey)
forall a. a -> Maybe a
Just (Revision
revision, BlobKey
cfKey, TreeKey
treeKey')

-- | Fetch keys and blobs and insert into the database where possible.

fetchTreeKeys ::
     (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => [RawPackageLocationImmutable]
  -> RIO env ()
fetchTreeKeys :: 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] <-
    ReaderT SqlBackend (RIO env) [RawPackageLocationImmutable]
-> RIO env [RawPackageLocationImmutable]
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage
      ((RawPackageLocationImmutable -> ReaderT SqlBackend (RIO env) Bool)
-> [RawPackageLocationImmutable]
-> ReaderT SqlBackend (RIO env) [RawPackageLocationImmutable]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM
         ((Maybe (Entity Tree) -> Bool)
-> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
-> ReaderT SqlBackend (RIO env) Bool
forall a b.
(a -> b)
-> ReaderT SqlBackend (RIO env) a -> ReaderT SqlBackend (RIO env) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Entity Tree) -> Bool
forall a. Maybe a -> Bool
isNothing (ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
 -> ReaderT SqlBackend (RIO env) Bool)
-> (RawPackageLocationImmutable
    -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree)))
-> RawPackageLocationImmutable
-> ReaderT SqlBackend (RIO env) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
-> (TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree)))
-> Maybe TreeKey
-> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe (Entity Tree)
-> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Entity Tree)
forall a. Maybe a
Nothing) TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
forall env.
TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
getTreeForKey (Maybe TreeKey
 -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree)))
-> (RawPackageLocationImmutable -> Maybe TreeKey)
-> RawPackageLocationImmutable
-> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawPackageLocationImmutable -> Maybe TreeKey
getRawTreeKey)
         [RawPackageLocationImmutable]
treeKeys)
  UTCTime
pullTreeStart <- IO UTCTime -> RIO env UTCTime
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  -- Pull down those tree keys from Casa, automatically inserting into

  -- our local database.

  Map TreeKey Tree
treeKeyBlobs :: Map TreeKey P.Tree <-
    (SomeException -> RIO env (Map TreeKey Tree))
-> RIO env (Map TreeKey Tree) -> RIO env (Map TreeKey Tree)
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny (RIO env (Map TreeKey Tree)
-> SomeException -> RIO env (Map TreeKey Tree)
forall a b. a -> b -> a
const RIO env (Map TreeKey Tree)
forall a. Monoid a => a
mempty)
    (([(TreeKey, Tree)] -> Map TreeKey Tree)
-> RIO env [(TreeKey, Tree)] -> RIO env (Map TreeKey Tree)
forall a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      [(TreeKey, Tree)] -> Map TreeKey Tree
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      (ReaderT SqlBackend (RIO env) [(TreeKey, Tree)]
-> RIO env [(TreeKey, Tree)]
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage
         (ConduitT
  ()
  Void
  (ResourceT (ReaderT SqlBackend (RIO env)))
  [(TreeKey, Tree)]
-> ReaderT SqlBackend (RIO env) [(TreeKey, Tree)]
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes
            ([BlobKey]
-> ConduitT
     ()
     (BlobKey, ByteString)
     (ResourceT (ReaderT SqlBackend (RIO env)))
     ()
forall (f :: * -> *) env i.
(Foldable f, HasPantryConfig env, HasLogFunc env) =>
f BlobKey
-> ConduitT
     i
     (BlobKey, ByteString)
     (ResourceT (ReaderT SqlBackend (RIO env)))
     ()
casaBlobSource
               ((TreeKey -> BlobKey) -> [TreeKey] -> [BlobKey]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TreeKey -> BlobKey
unTreeKey ((RawPackageLocationImmutable -> Maybe TreeKey)
-> [RawPackageLocationImmutable] -> [TreeKey]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe RawPackageLocationImmutable -> Maybe TreeKey
getRawTreeKey [RawPackageLocationImmutable]
packageLocationsMissing)) ConduitT
  ()
  (BlobKey, ByteString)
  (ResourceT (ReaderT SqlBackend (RIO env)))
  ()
-> ConduitT
     (BlobKey, ByteString)
     Void
     (ResourceT (ReaderT SqlBackend (RIO env)))
     [(TreeKey, Tree)]
-> ConduitT
     ()
     Void
     (ResourceT (ReaderT SqlBackend (RIO env)))
     [(TreeKey, Tree)]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.|
             ((BlobKey, ByteString)
 -> ResourceT (ReaderT SqlBackend (RIO env)) (TreeKey, Tree))
-> ConduitT
     (BlobKey, ByteString)
     (TreeKey, Tree)
     (ResourceT (ReaderT SqlBackend (RIO env)))
     ()
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConduitT a b m ()
mapMC (BlobKey, ByteString)
-> ResourceT (ReaderT SqlBackend (RIO env)) (TreeKey, Tree)
forall (m :: * -> *).
MonadThrow m =>
(BlobKey, ByteString) -> m (TreeKey, Tree)
parseTreeM ConduitT
  (BlobKey, ByteString)
  (TreeKey, Tree)
  (ResourceT (ReaderT SqlBackend (RIO env)))
  ()
-> ConduitT
     (TreeKey, Tree)
     Void
     (ResourceT (ReaderT SqlBackend (RIO env)))
     [(TreeKey, Tree)]
-> ConduitT
     (BlobKey, ByteString)
     Void
     (ResourceT (ReaderT SqlBackend (RIO env)))
     [(TreeKey, Tree)]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.|
             ConduitT
  (TreeKey, Tree)
  Void
  (ResourceT (ReaderT SqlBackend (RIO env)))
  [(TreeKey, Tree)]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
sinkList))))
  UTCTime
pullTreeEnd <- IO UTCTime -> RIO env UTCTime
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  let pulledPackages :: [RawPackageLocationImmutable]
pulledPackages =
        (TreeKey -> Maybe RawPackageLocationImmutable)
-> [TreeKey] -> [RawPackageLocationImmutable]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
          (\TreeKey
treeKey' ->
             (RawPackageLocationImmutable -> Bool)
-> [RawPackageLocationImmutable]
-> Maybe RawPackageLocationImmutable
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find
               ((Maybe TreeKey -> Maybe TreeKey -> Bool
forall a. Eq a => a -> a -> Bool
== TreeKey -> Maybe TreeKey
forall a. a -> Maybe a
Just TreeKey
treeKey') (Maybe TreeKey -> Bool)
-> (RawPackageLocationImmutable -> Maybe TreeKey)
-> RawPackageLocationImmutable
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawPackageLocationImmutable -> Maybe TreeKey
getRawTreeKey)
               [RawPackageLocationImmutable]
packageLocationsMissing)
          (Map TreeKey Tree -> [TreeKey]
forall k a. Map k a -> [k]
Map.keys Map TreeKey Tree
treeKeyBlobs)
  -- Pull down all unique file blobs.

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

  [RawPackageLocationImmutable]
-> (RawPackageLocationImmutable -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_
    [RawPackageLocationImmutable]
packageLocationsMissing
    (\RawPackageLocationImmutable
rawPackageLocationImmutable ->
       let mkey :: Maybe TreeKey
mkey = RawPackageLocationImmutable -> Maybe TreeKey
getRawTreeKey RawPackageLocationImmutable
rawPackageLocationImmutable
        in case Maybe TreeKey
mkey of
             Maybe TreeKey
Nothing ->
               Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug
                 (Utf8Builder
"Ignoring package with no tree key " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                  RawPackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
rawPackageLocationImmutable Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                  Utf8Builder
", can't look in Casa for it.")
             Just TreeKey
key ->
               case TreeKey -> Map TreeKey Tree -> Maybe Tree
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TreeKey
key Map TreeKey Tree
treeKeyBlobs of
                 Maybe Tree
Nothing ->
                   Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug
                     (Utf8Builder
"Package key " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> TreeKey -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display TreeKey
key Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" (" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                      RawPackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
rawPackageLocationImmutable Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                      Utf8Builder
") not returned from Casa.")
                 Just Tree
tree -> do
                   PackageIdentifier
identifier <-
                     RawPackageLocationImmutable -> RIO env PackageIdentifier
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env PackageIdentifier
getRawPackageLocationIdent RawPackageLocationImmutable
rawPackageLocationImmutable
                   case RawPackageLocationImmutable -> Tree -> Maybe BuildFile
forall (m :: * -> *).
MonadThrow m =>
RawPackageLocationImmutable -> Tree -> m BuildFile
findCabalOrHpackFile RawPackageLocationImmutable
rawPackageLocationImmutable Tree
tree of
                     Just BuildFile
buildFile -> ReaderT SqlBackend (RIO env) () -> RIO env ()
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) () -> RIO env ())
-> ReaderT SqlBackend (RIO env) () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
                       Either LoadCachedTreeException CachedTree
ecachedTree <- Tree
-> ReaderT
     SqlBackend (RIO env) (Either LoadCachedTreeException CachedTree)
forall env.
Tree
-> ReaderT
     SqlBackend (RIO env) (Either LoadCachedTreeException CachedTree)
loadCachedTree Tree
tree
                       case Either LoadCachedTreeException CachedTree
ecachedTree of
                         Left LoadCachedTreeException
e ->
                           RIO env () -> ReaderT SqlBackend (RIO env) ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT SqlBackend m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RIO env () -> ReaderT SqlBackend (RIO env) ())
-> RIO env () -> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn
                           (Utf8Builder
"Loading cached tree after download from Casa failed on " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                            RawPackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
rawPackageLocationImmutable Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                            LoadCachedTreeException -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow LoadCachedTreeException
e)
                         Right CachedTree
cachedTree ->
                           ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
-> ReaderT SqlBackend (RIO env) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
 -> ReaderT SqlBackend (RIO env) ())
-> ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
-> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable
-> PackageIdentifier
-> CachedTree
-> BuildFile
-> ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> PackageIdentifier
-> CachedTree
-> BuildFile
-> ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
storeTree
                             RawPackageLocationImmutable
rawPackageLocationImmutable
                             PackageIdentifier
identifier
                             CachedTree
cachedTree
                             BuildFile
buildFile
                     Maybe BuildFile
Nothing ->
                       Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn
                         (Utf8Builder
"Unable to find build file for package: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                          RawPackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
rawPackageLocationImmutable))
  where
    unTreeKey :: TreeKey -> BlobKey
    unTreeKey :: TreeKey -> BlobKey
unTreeKey (P.TreeKey BlobKey
blobKey) = BlobKey
blobKey

-- | Download all of the packages provided into the local cache without

-- performing any unpacking. Can be useful for build tools wanting to prefetch

-- or provide an offline mode.

--

-- @since 0.1.0.0

fetchPackages ::
     (HasPantryConfig env, HasLogFunc env, HasProcessContext env, Foldable f)
  => f PackageLocationImmutable
  -> RIO env ()
fetchPackages :: forall env (f :: * -> *).
(HasPantryConfig env, HasLogFunc env, HasProcessContext env,
 Foldable f) =>
f PackageLocationImmutable -> RIO env ()
fetchPackages f PackageLocationImmutable
pls = do
  [RawPackageLocationImmutable] -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
[RawPackageLocationImmutable] -> RIO env ()
fetchTreeKeys ((PackageLocationImmutable -> RawPackageLocationImmutable)
-> [PackageLocationImmutable] -> [RawPackageLocationImmutable]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI (f PackageLocationImmutable -> [PackageLocationImmutable]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f PackageLocationImmutable
pls))
  ((PackageIdentifierRevision, Maybe TreeKey) -> RIO env ())
-> [(PackageIdentifierRevision, Maybe TreeKey)] -> RIO env ()
forall (f :: * -> *) env a.
(Foldable f, HasPantryConfig env) =>
(a -> RIO env ()) -> f a -> RIO env ()
traverseConcurrently_ (RIO env HackageTarballResult -> RIO env ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RIO env HackageTarballResult -> RIO env ())
-> ((PackageIdentifierRevision, Maybe TreeKey)
    -> RIO env HackageTarballResult)
-> (PackageIdentifierRevision, Maybe TreeKey)
-> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageIdentifierRevision
 -> Maybe TreeKey -> RIO env HackageTarballResult)
-> (PackageIdentifierRevision, Maybe TreeKey)
-> RIO env HackageTarballResult
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PackageIdentifierRevision
-> Maybe TreeKey -> RIO env HackageTarballResult
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageIdentifierRevision
-> Maybe TreeKey -> RIO env HackageTarballResult
getHackageTarball) [(PackageIdentifierRevision, Maybe TreeKey)]
hackages
  -- TODO in the future, be concurrent in these as well

  [(Archive, PackageMetadata)] -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
[(Archive, PackageMetadata)] -> RIO env ()
fetchArchives [(Archive, PackageMetadata)]
archives
  [(Repo, PackageMetadata)] -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
[(Repo, PackageMetadata)] -> RIO env ()
fetchRepos [(Repo, PackageMetadata)]
repos
 where
  s :: a -> Endo [a]
s a
x = ([a] -> [a]) -> Endo [a]
forall a. (a -> a) -> Endo a
Endo (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:)
  run :: Endo [a] -> [a]
run (Endo [a] -> [a]
f) = [a] -> [a]
f []
  (Endo [(PackageIdentifierRevision, Maybe TreeKey)]
hackagesE, Endo [(Archive, PackageMetadata)]
archivesE, Endo [(Repo, PackageMetadata)]
reposE) = (PackageLocationImmutable
 -> (Endo [(PackageIdentifierRevision, Maybe TreeKey)],
     Endo [(Archive, PackageMetadata)], Endo [(Repo, PackageMetadata)]))
-> f PackageLocationImmutable
-> (Endo [(PackageIdentifierRevision, Maybe TreeKey)],
    Endo [(Archive, PackageMetadata)], Endo [(Repo, PackageMetadata)])
forall m a. Monoid m => (a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap PackageLocationImmutable
-> (Endo [(PackageIdentifierRevision, Maybe TreeKey)],
    Endo [(Archive, PackageMetadata)], Endo [(Repo, PackageMetadata)])
go f PackageLocationImmutable
pls
  hackages :: [(PackageIdentifierRevision, Maybe TreeKey)]
hackages = Endo [(PackageIdentifierRevision, Maybe TreeKey)]
-> [(PackageIdentifierRevision, Maybe TreeKey)]
forall {a}. Endo [a] -> [a]
run Endo [(PackageIdentifierRevision, Maybe TreeKey)]
hackagesE
  archives :: [(Archive, PackageMetadata)]
archives = Endo [(Archive, PackageMetadata)] -> [(Archive, PackageMetadata)]
forall {a}. Endo [a] -> [a]
run Endo [(Archive, PackageMetadata)]
archivesE
  repos :: [(Repo, PackageMetadata)]
repos = Endo [(Repo, PackageMetadata)] -> [(Repo, PackageMetadata)]
forall {a}. Endo [a] -> [a]
run Endo [(Repo, PackageMetadata)]
reposE

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

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

-- | Unpack a given 'RawPackageLocationImmutable' into the given directory. Does

-- not generate any extra subdirectories.

--

-- @since 0.1.0.0

unpackPackageLocationRaw ::
     (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => Path Abs Dir -- ^ unpack directory

  -> RawPackageLocationImmutable
  -> RIO env ()
unpackPackageLocationRaw :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir -> RawPackageLocationImmutable -> RIO env ()
unpackPackageLocationRaw Path Abs Dir
fp RawPackageLocationImmutable
loc =
  RawPackageLocationImmutable -> RIO env Package
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env Package
loadPackageRaw RawPackageLocationImmutable
loc RIO env Package -> (Package -> RIO env ()) -> RIO env ()
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RawPackageLocationImmutable -> Path Abs Dir -> Tree -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawPackageLocationImmutable -> Path Abs Dir -> Tree -> RIO env ()
unpackTree RawPackageLocationImmutable
loc Path Abs Dir
fp (Tree -> RIO env ()) -> (Package -> Tree) -> Package -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Package -> Tree
packageTree

-- | Unpack a given 'PackageLocationImmutable' into the given directory. Does

-- not generate any extra subdirectories.

--

-- @since 0.1.0.0

unpackPackageLocation ::
     (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => Path Abs Dir -- ^ unpack directory

  -> PackageLocationImmutable
  -> RIO env ()
unpackPackageLocation :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir -> PackageLocationImmutable -> RIO env ()
unpackPackageLocation Path Abs Dir
fp PackageLocationImmutable
loc =
  PackageLocationImmutable -> RIO env Package
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageLocationImmutable -> RIO env Package
loadPackage PackageLocationImmutable
loc RIO env Package -> (Package -> RIO env ()) -> RIO env ()
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RawPackageLocationImmutable -> Path Abs Dir -> Tree -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawPackageLocationImmutable -> Path Abs Dir -> Tree -> RIO env ()
unpackTree (PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI PackageLocationImmutable
loc) Path Abs Dir
fp (Tree -> RIO env ()) -> (Package -> Tree) -> Package -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Package -> Tree
packageTree

-- | Load the cabal file for the given 'PackageLocationImmutable'.

--

-- This function ignores all warnings.

--

-- @since 0.1.0.0

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

-- | Load the cabal file for the given 'RawPackageLocationImmutable'.

--

-- This function ignores all warnings.

--

-- Note that, for now, this will not allow support for hpack files in these

-- package locations. Instead, all @PackageLocationImmutable@s will require a

-- .cabal file. This may be relaxed in the future.

--

-- @since 0.1.0.0

loadCabalFileRawImmutable ::
     (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => RawPackageLocationImmutable
  -> RIO env GenericPackageDescription
loadCabalFileRawImmutable :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env GenericPackageDescription
loadCabalFileRawImmutable RawPackageLocationImmutable
loc = RIO env GenericPackageDescription
-> RIO env GenericPackageDescription
forall {m :: * -> *} {s}.
(MonadReader s m, HasPantryConfig s, MonadIO m) =>
m GenericPackageDescription -> m GenericPackageDescription
withCache (RIO env GenericPackageDescription
 -> RIO env GenericPackageDescription)
-> RIO env GenericPackageDescription
-> RIO env GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ do
  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Parsing cabal file for " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> RawPackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
loc
  ByteString
bs <- RawPackageLocationImmutable -> RIO env ByteString
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env ByteString
loadRawCabalFileBytes RawPackageLocationImmutable
loc
  ([PWarning]
_warnings, GenericPackageDescription
gpd) <- Either RawPackageLocationImmutable (Path Abs File)
-> ByteString -> RIO env ([PWarning], GenericPackageDescription)
forall (m :: * -> *).
MonadThrow m =>
Either RawPackageLocationImmutable (Path Abs File)
-> ByteString -> m ([PWarning], GenericPackageDescription)
rawParseGPD (RawPackageLocationImmutable
-> Either RawPackageLocationImmutable (Path Abs File)
forall a b. a -> Either a b
Left RawPackageLocationImmutable
loc) ByteString
bs
  let rpm :: RawPackageMetadata
rpm =
        case RawPackageLocationImmutable
loc of
          RPLIHackage (PackageIdentifierRevision PackageName
name Version
version CabalFileInfo
_cfi) Maybe TreeKey
mtree -> RawPackageMetadata
            { rpmName :: Maybe PackageName
rpmName = PackageName -> Maybe PackageName
forall a. a -> Maybe a
Just PackageName
name
            , rpmVersion :: Maybe Version
rpmVersion = Version -> Maybe Version
forall a. a -> Maybe a
Just Version
version
            , rpmTreeKey :: Maybe TreeKey
rpmTreeKey = Maybe TreeKey
mtree
            }
          RPLIArchive RawArchive
_ RawPackageMetadata
rpm' -> RawPackageMetadata
rpm'
          RPLIRepo Repo
_ RawPackageMetadata
rpm' -> RawPackageMetadata
rpm'
  let exc :: PantryException
exc = RawPackageLocationImmutable
-> RawPackageMetadata
-> Maybe TreeKey
-> PackageIdentifier
-> PantryException
MismatchedPackageMetadata RawPackageLocationImmutable
loc RawPackageMetadata
rpm Maybe TreeKey
forall a. Maybe a
Nothing (GenericPackageDescription -> PackageIdentifier
gpdPackageIdentifier GenericPackageDescription
gpd)
  RIO env GenericPackageDescription
-> (GenericPackageDescription -> RIO env GenericPackageDescription)
-> Maybe GenericPackageDescription
-> RIO env GenericPackageDescription
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PantryException -> RIO env GenericPackageDescription
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO PantryException
exc) GenericPackageDescription -> RIO env GenericPackageDescription
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe GenericPackageDescription
 -> RIO env GenericPackageDescription)
-> Maybe GenericPackageDescription
-> RIO env GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ do
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> (PackageName -> Bool) -> Maybe PackageName -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== GenericPackageDescription -> PackageName
gpdPackageName GenericPackageDescription
gpd) (RawPackageMetadata -> Maybe PackageName
rpmName RawPackageMetadata
rpm)
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> (Version -> Bool) -> Maybe Version -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== GenericPackageDescription -> Version
gpdVersion GenericPackageDescription
gpd) (RawPackageMetadata -> Maybe Version
rpmVersion RawPackageMetadata
rpm)
    GenericPackageDescription -> Maybe GenericPackageDescription
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenericPackageDescription
gpd
 where
  withCache :: m GenericPackageDescription -> m GenericPackageDescription
withCache m GenericPackageDescription
inner = do
    IORef (Map RawPackageLocationImmutable GenericPackageDescription)
ref <- Getting
  (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
  s
  (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
-> m (IORef
        (Map RawPackageLocationImmutable GenericPackageDescription))
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting
   (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
   s
   (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
 -> m (IORef
         (Map RawPackageLocationImmutable GenericPackageDescription)))
-> Getting
     (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
     s
     (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
-> m (IORef
        (Map RawPackageLocationImmutable GenericPackageDescription))
forall a b. (a -> b) -> a -> b
$ (PantryConfig
 -> Const
      (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
      PantryConfig)
-> s
-> Const
     (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
     s
forall env. HasPantryConfig env => Lens' env PantryConfig
Lens' s PantryConfig
pantryConfigL((PantryConfig
  -> Const
       (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
       PantryConfig)
 -> s
 -> Const
      (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
      s)
-> ((IORef
       (Map RawPackageLocationImmutable GenericPackageDescription)
     -> Const
          (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
          (IORef
             (Map RawPackageLocationImmutable GenericPackageDescription)))
    -> PantryConfig
    -> Const
         (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
         PantryConfig)
-> Getting
     (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
     s
     (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PantryConfig
 -> IORef
      (Map RawPackageLocationImmutable GenericPackageDescription))
-> SimpleGetter
     PantryConfig
     (IORef (Map RawPackageLocationImmutable GenericPackageDescription))
forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig
-> IORef
     (Map RawPackageLocationImmutable GenericPackageDescription)
pcParsedCabalFilesRawImmutable
    Map RawPackageLocationImmutable GenericPackageDescription
m0 <- IORef (Map RawPackageLocationImmutable GenericPackageDescription)
-> m (Map RawPackageLocationImmutable GenericPackageDescription)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Map RawPackageLocationImmutable GenericPackageDescription)
ref
    case RawPackageLocationImmutable
-> Map RawPackageLocationImmutable GenericPackageDescription
-> Maybe GenericPackageDescription
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RawPackageLocationImmutable
loc Map RawPackageLocationImmutable GenericPackageDescription
m0 of
      Just GenericPackageDescription
x -> GenericPackageDescription -> m GenericPackageDescription
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenericPackageDescription
x
      Maybe GenericPackageDescription
Nothing -> do
        GenericPackageDescription
x <- m GenericPackageDescription
inner
        IORef (Map RawPackageLocationImmutable GenericPackageDescription)
-> (Map RawPackageLocationImmutable GenericPackageDescription
    -> (Map RawPackageLocationImmutable GenericPackageDescription,
        GenericPackageDescription))
-> m GenericPackageDescription
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef (Map RawPackageLocationImmutable GenericPackageDescription)
ref ((Map RawPackageLocationImmutable GenericPackageDescription
  -> (Map RawPackageLocationImmutable GenericPackageDescription,
      GenericPackageDescription))
 -> m GenericPackageDescription)
-> (Map RawPackageLocationImmutable GenericPackageDescription
    -> (Map RawPackageLocationImmutable GenericPackageDescription,
        GenericPackageDescription))
-> m GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ \Map RawPackageLocationImmutable GenericPackageDescription
m -> (RawPackageLocationImmutable
-> GenericPackageDescription
-> Map RawPackageLocationImmutable GenericPackageDescription
-> Map RawPackageLocationImmutable GenericPackageDescription
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert RawPackageLocationImmutable
loc GenericPackageDescription
x Map RawPackageLocationImmutable GenericPackageDescription
m, GenericPackageDescription
x)

-- | Same as 'loadCabalFileRawImmutable', but takes a 'RawPackageLocation'.

-- Never prints warnings, see 'loadCabalFilePath' for that.

--

-- @since 0.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) = RawPackageLocationImmutable -> RIO env GenericPackageDescription
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
_) <- Maybe Text
-> Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, 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 (ResolvedPath Dir -> Path Abs Dir
forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath Dir
rfp)
  IO GenericPackageDescription -> RIO env GenericPackageDescription
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GenericPackageDescription -> RIO env GenericPackageDescription)
-> IO GenericPackageDescription
-> RIO env GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ PrintWarnings -> IO GenericPackageDescription
gpdio PrintWarnings
NoPrintWarnings

-- | Same as 'loadCabalFileImmutable', but takes a 'PackageLocation'. Never

-- prints warnings, see 'loadCabalFilePath' for that.

--

-- @since 0.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) = PackageLocationImmutable -> RIO env GenericPackageDescription
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
_) <- Maybe Text
-> Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, 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 (ResolvedPath Dir -> Path Abs Dir
forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath Dir
rfp)
  IO GenericPackageDescription -> RIO env GenericPackageDescription
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GenericPackageDescription -> RIO env GenericPackageDescription)
-> IO GenericPackageDescription
-> RIO env GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ PrintWarnings -> IO GenericPackageDescription
gpdio PrintWarnings
NoPrintWarnings

-- | Parse the Cabal file for the package inside the given directory. Performs

-- various sanity checks, such as the file name being correct and having only a

-- single Cabal file.

--

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

-- | Get the 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 = String -> ProgramName
forall a. IsString a => String -> a
fromString (String -> ProgramName) -> (Text -> String) -> Text -> ProgramName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack (Text -> ProgramName) -> Maybe Text -> Maybe ProgramName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
progName
  Maybe ProgramName -> Path Abs Dir -> RIO env ()
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) <- Path Abs Dir -> RIO env ([Path Abs Dir], [Path Abs File])
forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
pkgDir RIO env ([Path Abs Dir], [Path Abs File])
-> (IOException -> RIO env ([Path Abs Dir], [Path Abs File]))
-> RIO env ([Path Abs Dir], [Path Abs File])
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (IOException -> m a) -> m a
`catchIO` \IOException
e -> if IOException -> Bool
isDoesNotExistError IOException
e
    then PantryException -> RIO env ([Path Abs Dir], [Path Abs File])
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env ([Path Abs Dir], [Path Abs File]))
-> PantryException -> RIO env ([Path Abs Dir], [Path Abs File])
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> PantryException
NoLocalPackageDirFound Path Abs Dir
pkgDir
    else IOException -> RIO env ([Path Abs Dir], [Path Abs File])
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO IOException
e
  let files :: [Path Abs File]
files = (Path Abs File -> Bool) -> [Path Abs File] -> [Path Abs File]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> String -> Bool) -> String -> String -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> String -> Bool
hasExtension String
"cabal" (String -> Bool)
-> (Path Abs File -> String) -> Path Abs File -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> String
forall b t. Path b t -> String
toFilePath) [Path Abs File]
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 (Path Abs File -> Bool) -> [Path Abs File] -> [Path Abs File]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Path Abs File -> Bool) -> Path Abs File -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isHidden (String -> Bool)
-> (Path Abs File -> String) -> Path Abs File -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Rel File -> String
forall b t. Path b t -> String
toFilePath (Path Rel File -> String)
-> (Path Abs File -> Path Rel File) -> Path Abs File -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> Path Rel File
forall b. Path b File -> Path Rel File
filename) [Path Abs File]
files of
    [] -> PantryException -> RIO env (PackageName, Path Abs File)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env (PackageName, Path Abs File))
-> PantryException -> RIO env (PackageName, Path Abs File)
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> PantryException
NoCabalFileFound Path Abs Dir
pkgDir
    [Path Abs File
x] -> RIO env (PackageName, Path Abs File)
-> (PackageName -> RIO env (PackageName, Path Abs File))
-> Maybe PackageName
-> RIO env (PackageName, Path Abs File)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      (PantryException -> RIO env (PackageName, Path Abs File)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env (PackageName, Path Abs File))
-> PantryException -> RIO env (PackageName, Path Abs File)
forall a b. (a -> b) -> a -> b
$ Path Abs File -> PantryException
InvalidCabalFilePath Path Abs File
x)
      (\PackageName
pn -> (PackageName, Path Abs File)
-> RIO env (PackageName, Path Abs File)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageName
pn, Path Abs File
x)) (Maybe PackageName -> RIO env (PackageName, Path Abs File))
-> Maybe PackageName -> RIO env (PackageName, Path Abs File)
forall a b. (a -> b) -> a -> b
$
        String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripSuffix String
".cabal" (Path Rel File -> String
forall b t. Path b t -> String
toFilePath (Path Abs File -> Path Rel File
forall b. Path b File -> Path Rel File
filename Path Abs File
x)) Maybe String -> (String -> Maybe PackageName) -> Maybe PackageName
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        String -> Maybe PackageName
parsePackageName
    Path Abs File
_:[Path Abs File]
_ -> PantryException -> RIO env (PackageName, Path Abs File)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env (PackageName, Path Abs File))
-> PantryException -> RIO env (PackageName, Path Abs File)
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> [Path Abs File] -> PantryException
MultipleCabalFilesFound Path Abs Dir
pkgDir [Path Abs File]
files
 where
  hasExtension :: String -> String -> Bool
hasExtension String
fp String
x = String -> String
FilePath.takeExtension String
fp String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"." String -> String -> 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 <- String -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile String
Hpack.packageConfig
  let hpackFile :: Path Abs File
hpackFile = Path Abs Dir
pkgDir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
packageConfigRelFile
      mHpackProgName :: Options -> Options
mHpackProgName = (Options -> Options)
-> (ProgramName -> Options -> Options)
-> Maybe ProgramName
-> Options
-> Options
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Options -> Options
forall a. a -> a
id ProgramName -> Options -> Options
Hpack.setProgramName Maybe ProgramName
progName
  Bool
exists <- IO Bool -> RIO env Bool
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> RIO env Bool) -> IO Bool -> RIO env Bool
forall a b. (a -> b) -> a -> b
$ Path Abs File -> IO Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
hpackFile
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
    Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Running Hpack on " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
hpackFile)
    HpackExecutable
he <- Getting HpackExecutable env HpackExecutable
-> RIO env HpackExecutable
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting HpackExecutable env HpackExecutable
 -> RIO env HpackExecutable)
-> Getting HpackExecutable env HpackExecutable
-> RIO env HpackExecutable
forall a b. (a -> b) -> a -> b
$ (PantryConfig -> Const HpackExecutable PantryConfig)
-> env -> Const HpackExecutable env
forall env. HasPantryConfig env => Lens' env PantryConfig
Lens' env PantryConfig
pantryConfigL((PantryConfig -> Const HpackExecutable PantryConfig)
 -> env -> Const HpackExecutable env)
-> ((HpackExecutable -> Const HpackExecutable HpackExecutable)
    -> PantryConfig -> Const HpackExecutable PantryConfig)
-> Getting HpackExecutable env HpackExecutable
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PantryConfig -> HpackExecutable)
-> SimpleGetter PantryConfig HpackExecutable
forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig -> HpackExecutable
pcHpackExecutable
    Force
hpackForce <- Getting Force env Force -> RIO env Force
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting Force env Force -> RIO env Force)
-> Getting Force env Force -> RIO env Force
forall a b. (a -> b) -> a -> b
$ (PantryConfig -> Const Force PantryConfig)
-> env -> Const Force env
forall env. HasPantryConfig env => Lens' env PantryConfig
Lens' env PantryConfig
pantryConfigL((PantryConfig -> Const Force PantryConfig)
 -> env -> Const Force env)
-> ((Force -> Const Force Force)
    -> PantryConfig -> Const Force PantryConfig)
-> Getting Force env Force
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PantryConfig -> Force) -> SimpleGetter PantryConfig Force
forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig -> Force
pcHpackForce
    case HpackExecutable
he of
      HpackExecutable
HpackBundled ->
        IO (Either HpackError Result) -> RIO env (Either HpackError Result)
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
           ( Options -> IO (Either HpackError Result)
Hpack.hpackResultWithError
           (Options -> IO (Either HpackError Result))
-> Options -> IO (Either HpackError Result)
forall a b. (a -> b) -> a -> b
$ Options -> Options
mHpackProgName
           (Options -> Options) -> Options -> Options
forall a b. (a -> b) -> a -> b
$ (String -> IO (Either String ([String], Value)))
-> Options -> Options
Hpack.setDecode String -> IO (Either String ([String], Value))
decodeYaml
           (Options -> Options) -> Options -> Options
forall a b. (a -> b) -> a -> b
$ (String -> ParseException -> String) -> Options -> Options
Hpack.setFormatYamlParseError String -> ParseException -> String
formatYamlParseError
           (Options -> Options) -> Options -> Options
forall a b. (a -> b) -> a -> b
$ String -> Options -> Options
Hpack.setTarget
               (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
hpackFile)
               Options
Hpack.defaultOptions { Hpack.optionsForce = hpackForce }
           )
         RIO env (Either HpackError Result)
-> (Either HpackError Result -> RIO env ()) -> RIO env ()
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ case
        Left HpackError
err -> PantryException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (Path Abs File -> String -> PantryException
HpackLibraryException Path Abs File
hpackFile (String -> PantryException) -> String -> PantryException
forall a b. (a -> b) -> a -> b
$ ProgramName -> HpackError -> String
formatHpackError (ProgramName -> Maybe ProgramName -> ProgramName
forall a. a -> Maybe a -> a
fromMaybe ProgramName
"hpack" Maybe ProgramName
progName) HpackError
err)
        Right Result
r -> do
          [String] -> (String -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Result -> [String]
Hpack.resultWarnings Result
r) (Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ())
-> (String -> Utf8Builder) -> String -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Utf8Builder
forall a. IsString a => String -> a
fromString)
          let cabalFile :: Utf8Builder
cabalFile = String -> Utf8Builder
forall a. IsString a => String -> a
fromString (String -> Utf8Builder)
-> (Result -> String) -> Result -> Utf8Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> String
Hpack.resultCabalFile (Result -> Utf8Builder) -> Result -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ Result
r
          case Result -> Status
Hpack.resultStatus Result
r of
            Status
Hpack.Generated -> Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
                 Utf8Builder
"Hpack generated a modified version of "
              Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
cabalFile
            Status
Hpack.OutputUnchanged ->
              Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Hpack output unchanged in " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
cabalFile
            Status
Hpack.AlreadyGeneratedByNewerHpack -> Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
                 Utf8Builder
cabalFile
              Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" was generated with a newer version of Hpack. Ignoring "
              Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
hpackFile)
              Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" in favor of the Cabal file.\n"
              Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Either please upgrade and try again or, if you want to use the "
              Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Rel File -> String
forall b t. Path b t -> String
toFilePath (Path Abs File -> Path Rel File
forall b. Path b File -> Path Rel File
filename Path Abs File
hpackFile))
              Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" file instead of the Cabal file,\n"
              Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"then please delete the Cabal file."
            Status
Hpack.ExistingCabalFileWasModifiedManually -> Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
                 Utf8Builder
cabalFile
              Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" was modified manually. Ignoring "
              Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
hpackFile)
              Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" in favor of the Cabal file.\n"
              Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"If you want to use the "
              Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Rel File -> String
forall b t. Path b t -> String
toFilePath (Path Abs File -> Path Rel File
forall b. Path b File -> Path Rel File
filename Path Abs File
hpackFile))
              Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" file instead of the Cabal file,\n"
              Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"then please delete the Cabal file."
      HpackCommand String
command -> do
        let hpackArgs :: [String]
hpackArgs = case Force
hpackForce of
              Force
Hpack.Force -> [String
"--force"]
              Force
Hpack.NoForce -> []
        RIO env () -> (SomeException -> RIO env ()) -> RIO env ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
catchAny
          ( String -> RIO env () -> RIO env ()
forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
String -> m a -> m a
withWorkingDir (Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
pkgDir) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
            String
-> [String] -> (ProcessConfig () () () -> RIO env ()) -> RIO env ()
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
String -> [String] -> (ProcessConfig () () () -> m a) -> m a
proc String
command [String]
hpackArgs ProcessConfig () () () -> RIO env ()
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_
          )
          ( PantryException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env ())
-> (SomeException -> PantryException)
-> SomeException
-> RIO env ()
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 (PackageDescription -> PackageIdentifier)
-> (GenericPackageDescription -> PackageDescription)
-> GenericPackageDescription
-> PackageIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericPackageDescription -> PackageDescription
D.packageDescription

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

--

-- @since 0.1.0.0

gpdPackageName :: GenericPackageDescription -> PackageName
gpdPackageName :: GenericPackageDescription -> PackageName
gpdPackageName = PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> (GenericPackageDescription -> PackageIdentifier)
-> GenericPackageDescription
-> PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericPackageDescription -> PackageIdentifier
gpdPackageIdentifier

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

--

-- @since 0.1.0.0

gpdVersion :: GenericPackageDescription -> Version
gpdVersion :: GenericPackageDescription -> Version
gpdVersion = PackageIdentifier -> Version
pkgVersion (PackageIdentifier -> Version)
-> (GenericPackageDescription -> PackageIdentifier)
-> GenericPackageDescription
-> Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericPackageDescription -> PackageIdentifier
gpdPackageIdentifier

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

-- Just ignore the mtree for this. Safe assumption: someone who filled in the

-- TreeKey also filled in the cabal file hash, and that's a more efficient

-- lookup mechanism.

loadCabalFileBytes :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageLocationImmutable -> RIO env ByteString
loadCabalFileBytes (PLIHackage PackageIdentifier
pident BlobKey
cfHash TreeKey
_mtree) =
  PackageIdentifierRevision -> RIO env ByteString
forall env.
(HasPantryConfig env, HasLogFunc env) =>
PackageIdentifierRevision -> RIO env ByteString
getHackageCabalFile (PackageIdentifier -> BlobKey -> PackageIdentifierRevision
pirForHash PackageIdentifier
pident BlobKey
cfHash)

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

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

-- | Load a 'Package' from a 'RawPackageLocationImmutable'.

--

-- Load the package either from the local DB, Casa, or as a last resort, the

-- third party (hackage, archive or repo).

--

-- @since 0.1.0.0

loadPackageRaw ::
     (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => RawPackageLocationImmutable
  -> RIO env Package
loadPackageRaw :: 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 <- RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
forall env.
(HasLogFunc env, HasPantryConfig env, HasProcessContext env) =>
RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
tryLoadPackageRawViaDbOrCasa RawPackageLocationImmutable
rpli TreeKey
treeKey'
      RIO env Package
-> (Package -> RIO env Package) -> Maybe Package -> RIO env Package
forall b a. b -> (a -> b) -> Maybe a -> b
maybe RIO env Package
loadPackageRawViaThirdParty Package -> RIO env Package
forall a. a -> RIO env a
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
    Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Loading package from third-party: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> RawPackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
rpli)
    case RawPackageLocationImmutable
rpli of
      RPLIHackage PackageIdentifierRevision
pir Maybe TreeKey
mtree -> HackageTarballResult -> Package
htrPackage (HackageTarballResult -> Package)
-> RIO env HackageTarballResult -> RIO env Package
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageIdentifierRevision
-> Maybe TreeKey -> RIO env HackageTarballResult
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageIdentifierRevision
-> Maybe TreeKey -> RIO env HackageTarballResult
getHackageTarball PackageIdentifierRevision
pir Maybe TreeKey
mtree
      RPLIArchive RawArchive
archive RawPackageMetadata
pm -> RawPackageLocationImmutable
-> RawArchive -> RawPackageMetadata -> RIO env Package
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env,
 HasCallStack) =>
RawPackageLocationImmutable
-> RawArchive -> RawPackageMetadata -> RIO env Package
getArchivePackage RawPackageLocationImmutable
rpli RawArchive
archive RawPackageMetadata
pm
      RPLIRepo Repo
repo RawPackageMetadata
rpm -> Repo -> RawPackageMetadata -> RIO env Package
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Repo -> RawPackageMetadata -> RIO env Package
getRepo Repo
repo RawPackageMetadata
rpm

-- | Try to load a package via the database or Casa.

tryLoadPackageRawViaDbOrCasa ::
     (HasLogFunc env, HasPantryConfig env, HasProcessContext env)
  => RawPackageLocationImmutable
  -> TreeKey
  -> RIO env (Maybe Package)
tryLoadPackageRawViaDbOrCasa :: forall env.
(HasLogFunc env, HasPantryConfig env, HasProcessContext env) =>
RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
tryLoadPackageRawViaDbOrCasa RawPackageLocationImmutable
rpli TreeKey
treeKey' = MaybeT (RIO env) Package -> RIO env (Maybe Package)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (RIO env) Package -> RIO env (Maybe Package))
-> MaybeT (RIO env) Package -> RIO env (Maybe Package)
forall a b. (a -> b) -> a -> b
$
  MaybeT (RIO env) Package
tryViaLocalDb MaybeT (RIO env) Package
-> MaybeT (RIO env) Package -> MaybeT (RIO env) Package
forall a.
MaybeT (RIO env) a -> MaybeT (RIO env) a -> MaybeT (RIO env) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MaybeT (RIO env) Package
tryCasa
 where
  tryViaLocalDb :: MaybeT (RIO env) Package
tryViaLocalDb = do
    Package
package <- RIO env (Maybe Package) -> MaybeT (RIO env) Package
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (RIO env (Maybe Package) -> MaybeT (RIO env) Package)
-> RIO env (Maybe Package) -> MaybeT (RIO env) Package
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
forall env.
(HasLogFunc env, HasPantryConfig env, HasProcessContext env) =>
RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
tryLoadPackageRawViaLocalDb RawPackageLocationImmutable
rpli TreeKey
treeKey'
    RIO env () -> MaybeT (RIO env) ()
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RIO env () -> MaybeT (RIO env) ())
-> RIO env () -> MaybeT (RIO env) ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Loaded package from Pantry: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> RawPackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
rpli)
    Package -> MaybeT (RIO env) Package
forall a. a -> MaybeT (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Package
package
  tryCasa :: MaybeT (RIO env) Package
tryCasa = do
    MaybeT (RIO env) (CasaRepoPrefix, Int) -> MaybeT (RIO env) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (MaybeT (RIO env) (CasaRepoPrefix, Int) -> MaybeT (RIO env) ())
-> MaybeT (RIO env) (CasaRepoPrefix, Int) -> MaybeT (RIO env) ()
forall a b. (a -> b) -> a -> b
$ RIO env (Maybe (CasaRepoPrefix, Int))
-> MaybeT (RIO env) (CasaRepoPrefix, Int)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (RIO env (Maybe (CasaRepoPrefix, Int))
 -> MaybeT (RIO env) (CasaRepoPrefix, Int))
-> RIO env (Maybe (CasaRepoPrefix, Int))
-> MaybeT (RIO env) (CasaRepoPrefix, Int)
forall a b. (a -> b) -> a -> b
$ Getting
  (Maybe (CasaRepoPrefix, Int)) env (Maybe (CasaRepoPrefix, Int))
-> RIO env (Maybe (CasaRepoPrefix, Int))
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting
   (Maybe (CasaRepoPrefix, Int)) env (Maybe (CasaRepoPrefix, Int))
 -> RIO env (Maybe (CasaRepoPrefix, Int)))
-> Getting
     (Maybe (CasaRepoPrefix, Int)) env (Maybe (CasaRepoPrefix, Int))
-> RIO env (Maybe (CasaRepoPrefix, Int))
forall a b. (a -> b) -> a -> b
$ (PantryConfig -> Const (Maybe (CasaRepoPrefix, Int)) PantryConfig)
-> env -> Const (Maybe (CasaRepoPrefix, Int)) env
forall env. HasPantryConfig env => Lens' env PantryConfig
Lens' env PantryConfig
pantryConfigL ((PantryConfig -> Const (Maybe (CasaRepoPrefix, Int)) PantryConfig)
 -> env -> Const (Maybe (CasaRepoPrefix, Int)) env)
-> ((Maybe (CasaRepoPrefix, Int)
     -> Const
          (Maybe (CasaRepoPrefix, Int)) (Maybe (CasaRepoPrefix, Int)))
    -> PantryConfig
    -> Const (Maybe (CasaRepoPrefix, Int)) PantryConfig)
-> Getting
     (Maybe (CasaRepoPrefix, Int)) env (Maybe (CasaRepoPrefix, Int))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PantryConfig -> Maybe (CasaRepoPrefix, Int))
-> SimpleGetter PantryConfig (Maybe (CasaRepoPrefix, Int))
forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig -> Maybe (CasaRepoPrefix, Int)
pcCasaConfig
    Package
package <- RIO env (Maybe Package) -> MaybeT (RIO env) Package
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (RIO env (Maybe Package) -> MaybeT (RIO env) Package)
-> RIO env (Maybe Package) -> MaybeT (RIO env) Package
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
forall env.
(HasLogFunc env, HasPantryConfig env, HasProcessContext env) =>
RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
tryLoadPackageRawViaCasa RawPackageLocationImmutable
rpli TreeKey
treeKey'
    RIO env () -> MaybeT (RIO env) ()
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RIO env () -> MaybeT (RIO env) ())
-> RIO env () -> MaybeT (RIO env) ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Loaded package from Casa: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> RawPackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
rpli)
    Package -> MaybeT (RIO env) Package
forall a. a -> MaybeT (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Package
package

-- | 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' = MaybeT (RIO env) Package -> RIO env (Maybe Package)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (RIO env) Package -> RIO env (Maybe Package))
-> MaybeT (RIO env) Package -> RIO env (Maybe Package)
forall a b. (a -> b) -> a -> b
$ do
  (TreeKey
treeKey'', Tree
_) <- RIO env (Maybe (TreeKey, Tree)) -> MaybeT (RIO env) (TreeKey, Tree)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (RIO env (Maybe (TreeKey, Tree))
 -> MaybeT (RIO env) (TreeKey, Tree))
-> RIO env (Maybe (TreeKey, Tree))
-> MaybeT (RIO env) (TreeKey, Tree)
forall a b. (a -> b) -> a -> b
$ TreeKey -> RIO env (Maybe (TreeKey, Tree))
forall env.
(HasPantryConfig env, HasLogFunc env) =>
TreeKey -> RIO env (Maybe (TreeKey, Tree))
casaLookupTree TreeKey
treeKey'
  RIO env () -> MaybeT (RIO env) ()
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RIO env () -> MaybeT (RIO env) ())
-> RIO env () -> MaybeT (RIO env) ()
forall a b. (a -> b) -> a -> b
$ [RawPackageLocationImmutable] -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
[RawPackageLocationImmutable] -> RIO env ()
fetchTreeKeys [RawPackageLocationImmutable
rlpi]
  TreeKey -> MaybeT (RIO env) Package
tryViaLocalDb TreeKey
treeKey'' MaybeT (RIO env) Package
-> MaybeT (RIO env) Package -> MaybeT (RIO env) Package
forall a.
MaybeT (RIO env) a -> MaybeT (RIO env) a -> MaybeT (RIO env) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TreeKey -> MaybeT (RIO env) Package
forall {t :: (* -> *) -> * -> *} {m :: * -> *} {env} {a} {b}.
(MonadTrans t, Monad (t m), MonadIO m, MonadReader env m,
 HasLogFunc env, Display a, Alternative (t m)) =>
a -> t m b
warn TreeKey
treeKey''
 where
  tryViaLocalDb :: TreeKey -> MaybeT (RIO env) Package
tryViaLocalDb = RIO env (Maybe Package) -> MaybeT (RIO env) Package
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (RIO env (Maybe Package) -> MaybeT (RIO env) Package)
-> (TreeKey -> RIO env (Maybe Package))
-> TreeKey
-> MaybeT (RIO env) Package
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
forall env.
(HasLogFunc env, HasPantryConfig env, HasProcessContext env) =>
RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
tryLoadPackageRawViaLocalDb RawPackageLocationImmutable
rlpi
  warn :: a -> t m b
warn a
treeKey'' = do
    m () -> t m ()
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> t m ()) -> m () -> t m ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$
         Utf8Builder
"Did not find tree key in DB after pulling it from Casa: "
      Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> a -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display a
treeKey''
      Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" (for "
      Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> RawPackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
rlpi
      Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
")"
    t m b
forall a. t m a
forall (f :: * -> *) a. Alternative f => f a
empty

-- | 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' = MaybeT (RIO env) Package -> RIO env (Maybe Package)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (RIO env) Package -> RIO env (Maybe Package))
-> MaybeT (RIO env) Package -> RIO env (Maybe Package)
forall a b. (a -> b) -> a -> b
$ do
  Entity Tree
treeId <- RIO env (Maybe (Entity Tree)) -> MaybeT (RIO env) (Entity Tree)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (RIO env (Maybe (Entity Tree)) -> MaybeT (RIO env) (Entity Tree))
-> RIO env (Maybe (Entity Tree)) -> MaybeT (RIO env) (Entity Tree)
forall a b. (a -> b) -> a -> b
$ ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
-> RIO env (Maybe (Entity Tree))
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
forall env.
TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
getTreeForKey TreeKey
treeKey')
  RIO env Package -> MaybeT (RIO env) Package
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RIO env Package -> MaybeT (RIO env) Package)
-> RIO env Package -> MaybeT (RIO env) Package
forall a b. (a -> b) -> a -> b
$ ReaderT SqlBackend (RIO env) Package -> RIO env Package
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (RawPackageLocationImmutable
-> TreeId -> ReaderT SqlBackend (RIO env) Package
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> TreeId -> ReaderT SqlBackend (RIO env) Package
loadPackageById RawPackageLocationImmutable
rlpi (Entity Tree -> TreeId
forall record. Entity record -> Key record
entityKey Entity Tree
treeId))

-- | Complete package location, plus whether the package has a cabal file. This

-- is relevant to reproducibility, see

-- <https://tech.fpcomplete.com/blog/storing-generated-cabal-files>

--

-- @since 0.4.0.0

data CompletePackageLocation = CompletePackageLocation
  { CompletePackageLocation -> PackageLocationImmutable
cplComplete :: !PackageLocationImmutable
  , CompletePackageLocation -> Bool
cplHasCabalFile :: !Bool
  }

-- | Fill in optional fields in a 'PackageLocationImmutable' for more reproducible builds.

--

-- @since 0.1.0.0

completePackageLocation ::
     (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => RawPackageLocationImmutable
  -> RIO env CompletePackageLocation
completePackageLocation :: 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)) =
  CompletePackageLocation -> RIO env CompletePackageLocation
forall a. a -> RIO env a
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
  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Completing package location information from " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> PackageIdentifierRevision -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display PackageIdentifierRevision
pir0
  (PackageIdentifierRevision
pir, BlobKey
cfKey) <-
    case CabalFileInfo
cfi0 of
      CFIHash SHA256
sha (Just FileSize
size) -> (PackageIdentifierRevision, BlobKey)
-> RIO env (PackageIdentifierRevision, BlobKey)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageIdentifierRevision
pir0, SHA256 -> FileSize -> BlobKey
BlobKey SHA256
sha FileSize
size)
      CabalFileInfo
_ -> do
        ByteString
bs <- PackageIdentifierRevision -> RIO env ByteString
forall env.
(HasPantryConfig env, HasLogFunc env) =>
PackageIdentifierRevision -> RIO env ByteString
getHackageCabalFile PackageIdentifierRevision
pir0
        let size :: FileSize
size = Word -> FileSize
FileSize (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
bs))
            sha :: SHA256
sha = ByteString -> SHA256
SHA256.hashBytes ByteString
bs
            cfi :: CabalFileInfo
cfi = SHA256 -> Maybe FileSize -> CabalFileInfo
CFIHash SHA256
sha (FileSize -> Maybe FileSize
forall a. a -> Maybe a
Just FileSize
size)
            pir :: PackageIdentifierRevision
pir = PackageName
-> Version -> CabalFileInfo -> PackageIdentifierRevision
PackageIdentifierRevision PackageName
name Version
version CabalFileInfo
cfi
        Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Added in cabal file hash: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> PackageIdentifierRevision -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display PackageIdentifierRevision
pir
        (PackageIdentifierRevision, BlobKey)
-> RIO env (PackageIdentifierRevision, BlobKey)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageIdentifierRevision
pir, SHA256 -> FileSize -> BlobKey
BlobKey SHA256
sha FileSize
size)
  TreeKey
treeKey' <- PackageIdentifierRevision -> RIO env TreeKey
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageIdentifierRevision -> RIO env TreeKey
getHackageTarballKey PackageIdentifierRevision
pir
  CompletePackageLocation -> RIO env CompletePackageLocation
forall a. a -> RIO env a
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' -> RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
forall env.
(HasLogFunc env, HasPantryConfig env, HasProcessContext env) =>
RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
tryLoadPackageRawViaDbOrCasa RawPackageLocationImmutable
pl TreeKey
treeKey'
      Maybe TreeKey
Nothing -> Maybe Package -> RIO env (Maybe Package)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Package
forall a. Maybe a
Nothing
  case (,,) (SHA256 -> FileSize -> Package -> (SHA256, FileSize, Package))
-> Maybe SHA256
-> Maybe (FileSize -> Package -> (SHA256, FileSize, Package))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawArchive -> Maybe SHA256
raHash RawArchive
archive Maybe (FileSize -> Package -> (SHA256, FileSize, Package))
-> Maybe FileSize -> Maybe (Package -> (SHA256, FileSize, Package))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RawArchive -> Maybe FileSize
raSize RawArchive
archive Maybe (Package -> (SHA256, FileSize, Package))
-> Maybe Package -> Maybe (SHA256, FileSize, Package)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Package
mpackage of
    Just (SHA256
sha256, FileSize
fileSize, Package
package) -> do
      let RawArchive ArchiveLocation
loc Maybe SHA256
_ Maybe FileSize
_ Text
subdir = RawArchive
archive
      CompletePackageLocation -> RIO env CompletePackageLocation
forall a. a -> RIO env a
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 -> Bool -> RIO env CompletePackageLocation
forall {env}.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Bool -> RIO env CompletePackageLocation
byThirdParty (Maybe Package -> Bool
forall a. Maybe a -> Bool
isJust Maybe Package
mpackage)
 where
  byThirdParty :: Bool -> RIO env CompletePackageLocation
byThirdParty Bool
warnAboutMissingSizeSha = do
    (SHA256
sha, FileSize
size, Package
package, CachedTree
_cachedTree) <- RawPackageLocationImmutable
-> RawArchive
-> RawPackageMetadata
-> RIO env (SHA256, FileSize, Package, CachedTree)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env,
 HasCallStack) =>
RawPackageLocationImmutable
-> RawArchive
-> RawPackageMetadata
-> RIO env (SHA256, FileSize, Package, CachedTree)
getArchive RawPackageLocationImmutable
pl RawArchive
archive RawPackageMetadata
rpm
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
warnAboutMissingSizeSha (SHA256 -> FileSize -> RIO env ()
forall {m :: * -> *} {env} {a} {a}.
(MonadIO m, MonadReader env m, HasLogFunc env, Display a,
 Display a) =>
a -> a -> m ()
warnWith SHA256
sha FileSize
size)
    -- (getArchive checks archive and package metadata)

    let RawArchive ArchiveLocation
loc Maybe SHA256
_ Maybe FileSize
_ Text
subdir = RawArchive
archive
    Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ String -> Utf8Builder
forall a. IsString a => String -> a
fromString (String -> Utf8Builder) -> String -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ (RawPackageLocationImmutable, SHA256, FileSize, Package) -> String
forall a. Show a => a -> String
show (RawPackageLocationImmutable
pl, SHA256
sha, FileSize
size, Package
package)
    CompletePackageLocation -> RIO env CompletePackageLocation
forall a. a -> RIO env a
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 =
    Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn
      ([Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat
         [ Utf8Builder
"The package "
         , RawPackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
pl
         , Utf8Builder
" is available from the local content-addressable storage database, \n"
         , Utf8Builder
"but we can't use it unless you specify the size and hash for this package.\n"
         , Utf8Builder
"Add the following to your package description:\n"
         , Utf8Builder
"\nsize: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> a -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display a
size
         , Utf8Builder
"\nsha256: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> a -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display a
sha
         ])
completePackageLocation pl :: RawPackageLocationImmutable
pl@(RPLIRepo Repo
repo RawPackageMetadata
rpm) = do
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
isSHA1 (Repo -> Text
repoCommit Repo
repo)) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ PantryException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env ()) -> PantryException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Repo -> PantryException
CannotCompleteRepoNonSHA1 Repo
repo
  Repo
-> RawPackageLocationImmutable
-> RawPackageMetadata
-> RIO env CompletePackageLocation
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Repo
-> RawPackageLocationImmutable
-> RawPackageMetadata
-> RIO env CompletePackageLocation
completePM Repo
repo RawPackageLocationImmutable
pl RawPackageMetadata
rpm
 where
  isSHA1 :: Text -> Bool
isSHA1 Text
t = Text -> Int
T.length Text
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
40 Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isHexDigit Text
t

completePM ::
     (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => Repo
  -> RawPackageLocationImmutable
  -> RawPackageMetadata
  -> RIO env CompletePackageLocation
completePM :: 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
      CompletePackageLocation -> RIO env CompletePackageLocation
forall a. a -> RIO env a
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 <- RawPackageLocationImmutable -> RIO env Package
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env Package
loadPackageRaw RawPackageLocationImmutable
plOrig
      let pm :: PackageMetadata
pm = Package -> PackageMetadata
packagePM Package
package
      let isSame :: a -> Maybe a -> Bool
isSame a
x (Just a
y) = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y
          isSame a
_ Maybe a
_ = Bool
True

          allSame :: Bool
allSame =
            PackageName -> Maybe PackageName -> Bool
forall {a}. Eq a => a -> Maybe a -> Bool
isSame (PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> PackageIdentifier -> PackageName
forall a b. (a -> b) -> a -> b
$ PackageMetadata -> PackageIdentifier
pmIdent PackageMetadata
pm) (RawPackageMetadata -> Maybe PackageName
rpmName RawPackageMetadata
rpm) Bool -> Bool -> Bool
&&
            Version -> Maybe Version -> Bool
forall {a}. Eq a => a -> Maybe a -> Bool
isSame (PackageIdentifier -> Version
pkgVersion (PackageIdentifier -> Version) -> PackageIdentifier -> Version
forall a b. (a -> b) -> a -> b
$ PackageMetadata -> PackageIdentifier
pmIdent PackageMetadata
pm) (RawPackageMetadata -> Maybe Version
rpmVersion RawPackageMetadata
rpm) Bool -> Bool -> Bool
&&
            TreeKey -> Maybe TreeKey -> Bool
forall {a}. Eq a => a -> Maybe a -> Bool
isSame (PackageMetadata -> TreeKey
pmTreeKey PackageMetadata
pm) (RawPackageMetadata -> Maybe TreeKey
rpmTreeKey RawPackageMetadata
rpm)
      if Bool
allSame
        then CompletePackageLocation -> RIO env CompletePackageLocation
forall a. a -> RIO env a
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 PantryException -> RIO env CompletePackageLocation
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env CompletePackageLocation)
-> PantryException -> RIO env CompletePackageLocation
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable -> PackageMetadata -> PantryException
CompletePackageMetadataMismatch RawPackageLocationImmutable
plOrig PackageMetadata
pm

packagePM :: Package -> PackageMetadata
packagePM :: Package -> PackageMetadata
packagePM Package
package = PackageMetadata
  { 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) = SnapshotLocation -> RIO env SnapshotLocation
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SnapshotLocation -> RIO env SnapshotLocation)
-> SnapshotLocation -> RIO env SnapshotLocation
forall a b. (a -> b) -> a -> b
$ WantedCompiler -> SnapshotLocation
SLCompiler WantedCompiler
c
completeSnapshotLocation (RSLFilePath ResolvedPath File
f) = SnapshotLocation -> RIO env SnapshotLocation
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SnapshotLocation -> RIO env SnapshotLocation)
-> SnapshotLocation -> RIO env SnapshotLocation
forall a b. (a -> b) -> a -> b
$ ResolvedPath File -> SnapshotLocation
SLFilePath ResolvedPath File
f
completeSnapshotLocation (RSLUrl Text
url (Just BlobKey
blobKey)) = SnapshotLocation -> RIO env SnapshotLocation
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SnapshotLocation -> RIO env SnapshotLocation)
-> SnapshotLocation -> RIO env SnapshotLocation
forall a b. (a -> b) -> a -> b
$ Text -> BlobKey -> SnapshotLocation
SLUrl Text
url BlobKey
blobKey
completeSnapshotLocation (RSLUrl Text
url Maybe BlobKey
Nothing) = do
  ByteString
bs <- Text -> Maybe BlobKey -> RIO env ByteString
forall env.
(HasPantryConfig env, HasLogFunc env) =>
Text -> Maybe BlobKey -> RIO env ByteString
loadFromURL Text
url Maybe BlobKey
forall a. Maybe a
Nothing
  SnapshotLocation -> RIO env SnapshotLocation
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SnapshotLocation -> RIO env SnapshotLocation)
-> SnapshotLocation -> RIO env SnapshotLocation
forall a b. (a -> b) -> a -> b
$ Text -> BlobKey -> SnapshotLocation
SLUrl Text
url (ByteString -> BlobKey
bsToBlobKey ByteString
bs)
completeSnapshotLocation (RSLSynonym SnapName
syn) =
  RawSnapshotLocation -> RIO env SnapshotLocation
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawSnapshotLocation -> RIO env SnapshotLocation
completeSnapshotLocation (RawSnapshotLocation -> RIO env SnapshotLocation)
-> RIO env RawSnapshotLocation -> RIO env SnapshotLocation
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SnapName -> RIO env RawSnapshotLocation
forall env.
HasPantryConfig env =>
SnapName -> RIO env RawSnapshotLocation
snapshotLocation SnapName
syn

traverseConcurrently_ ::
     (Foldable f, HasPantryConfig env)
  => (a -> RIO env ()) -- ^ action to perform

  -> f a -- ^ input values

  -> RIO env ()
traverseConcurrently_ :: 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 <- Getting Int env Int -> RIO env Int
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting Int env Int -> RIO env Int)
-> Getting Int env Int -> RIO env Int
forall a b. (a -> b) -> a -> b
$ (PantryConfig -> Const Int PantryConfig) -> env -> Const Int env
forall env. HasPantryConfig env => Lens' env PantryConfig
Lens' env PantryConfig
pantryConfigL((PantryConfig -> Const Int PantryConfig) -> env -> Const Int env)
-> ((Int -> Const Int Int)
    -> PantryConfig -> Const Int PantryConfig)
-> Getting Int env Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PantryConfig -> Int) -> SimpleGetter PantryConfig Int
forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig -> Int
pcConnectionCount
  Int -> (a -> RIO env ()) -> f a -> RIO env ()
forall (m :: * -> *) (f :: * -> *) a.
(MonadUnliftIO m, Foldable f) =>
Int -> (a -> m ()) -> f a -> m ()
traverseConcurrentlyWith_ Int
cnt a -> RIO env ()
f f a
t0

traverseConcurrentlyWith_ ::
     (MonadUnliftIO m, Foldable f)
  => Int -- ^ concurrent workers

  -> (a -> m ()) -- ^ action to perform

  -> f a -- ^ input values

  -> m ()
traverseConcurrentlyWith_ :: 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 <- [a] -> m (TVar [a])
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO ([a] -> m (TVar [a])) -> [a] -> m (TVar [a])
forall a b. (a -> b) -> a -> b
$ f a -> [a]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f a
t0

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

-- | Parse a 'RawSnapshot' (all layers) from a 'RawSnapshotLocation'.

--

-- @since 0.1.0.0

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

-- | Parse a 'RawSnapshot' (all layers) from a 'SnapshotLocation'.

--

-- @since 0.1.0.0

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

-- | A completed package location, including the original raw and completed

-- information.

--

-- @since 0.1.0.0

data CompletedPLI
  = CompletedPLI !RawPackageLocationImmutable !PackageLocationImmutable

-- | A completed snapshot location, including the original raw and completed

-- information.

--

-- @since 0.1.0.0

data CompletedSL = CompletedSL !RawSnapshotLocation !SnapshotLocation

-- | Parse a 'Snapshot' (all layers) from a 'SnapshotLocation' noting any

-- incomplete package locations. 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 = Bool
-> SnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
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 =
  Bool
-> RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
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 = Bool
-> RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
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 RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Maybe SnapshotLocation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RawSnapshotLocation
rawLoc Map RawSnapshotLocation SnapshotLocation
cacheSL of
    Just SnapshotLocation
loc -> (RawSnapshotLayer -> (RawSnapshotLayer, CompletedSL))
-> Either WantedCompiler RawSnapshotLayer
-> Either WantedCompiler (RawSnapshotLayer, CompletedSL)
forall b c d. (b -> c) -> Either d b -> Either d c
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) (Either WantedCompiler RawSnapshotLayer
 -> Either WantedCompiler (RawSnapshotLayer, CompletedSL))
-> RIO env (Either WantedCompiler RawSnapshotLayer)
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SnapshotLocation
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall env.
(HasPantryConfig env, HasLogFunc env) =>
SnapshotLocation
-> RIO env (Either WantedCompiler RawSnapshotLayer)
loadSnapshotLayer SnapshotLocation
loc
    Maybe SnapshotLocation
Nothing -> RawSnapshotLocation
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawSnapshotLocation
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
loadRawSnapshotLayer RawSnapshotLocation
rawLoc
  case Either WantedCompiler (RawSnapshotLayer, CompletedSL)
eres of
    Left WantedCompiler
wc ->
      let snapshot :: Snapshot
snapshot = Snapshot
            { snapshotCompiler :: WantedCompiler
snapshotCompiler = WantedCompiler
wc
            , snapshotPackages :: Map PackageName SnapshotPackage
snapshotPackages = Map PackageName SnapshotPackage
forall a. Monoid a => a
mempty
            , snapshotDrop :: Set PackageName
snapshotDrop = Set PackageName
forall a. Monoid a => a
mempty
            }
      in (Snapshot, [CompletedSL], [CompletedPLI])
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
forall a. a -> RIO env a
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) <- Bool
-> RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
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
      Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugRSL (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ String -> Utf8Builder
forall a. IsString a => String -> a
fromString (String -> Utf8Builder) -> String -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ RawSnapshotLayer -> String
forall a. Show a => a -> String
show RawSnapshotLayer
rsl
      (Map PackageName SnapshotPackage
packages, [CompletedPLI]
completed, AddPackagesConfig
unused) <-
        RawSnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> [RawPackageLocationImmutable]
-> AddPackagesConfig
-> Map PackageName SnapshotPackage
-> RIO
     env
     (Map PackageName SnapshotPackage, [CompletedPLI],
      AddPackagesConfig)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawSnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> [RawPackageLocationImmutable]
-> AddPackagesConfig
-> Map PackageName SnapshotPackage
-> RIO
     env
     (Map PackageName SnapshotPackage, [CompletedPLI],
      AddPackagesConfig)
addAndCompletePackagesToSnapshot
          RawSnapshotLocation
rawLoc
          Map RawPackageLocationImmutable PackageLocationImmutable
cachePL
          (RawSnapshotLayer -> [RawPackageLocationImmutable]
rslLocations RawSnapshotLayer
rsl)
          AddPackagesConfig
            { apcDrop :: Set PackageName
apcDrop = RawSnapshotLayer -> Set PackageName
rslDropPackages RawSnapshotLayer
rsl
            , apcFlags :: Map PackageName (Map FlagName Bool)
apcFlags = RawSnapshotLayer -> Map PackageName (Map FlagName Bool)
rslFlags RawSnapshotLayer
rsl
            , apcHiddens :: Map PackageName Bool
apcHiddens = RawSnapshotLayer -> Map PackageName Bool
rslHidden RawSnapshotLayer
rsl
            , apcGhcOptions :: Map PackageName [Text]
apcGhcOptions = RawSnapshotLayer -> Map PackageName [Text]
rslGhcOptions RawSnapshotLayer
rsl
            }
          (Snapshot -> Map PackageName SnapshotPackage
snapshotPackages Snapshot
snap0)
      Utf8Builder -> AddPackagesConfig -> RIO env ()
forall env.
HasLogFunc env =>
Utf8Builder -> AddPackagesConfig -> RIO env ()
warnUnusedAddPackagesConfig (RawSnapshotLocation -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
rawLoc) AddPackagesConfig
unused
      let snapshot :: Snapshot
snapshot = Snapshot
            { snapshotCompiler :: WantedCompiler
snapshotCompiler = WantedCompiler -> Maybe WantedCompiler -> WantedCompiler
forall a. a -> Maybe a -> a
fromMaybe (Snapshot -> WantedCompiler
snapshotCompiler Snapshot
snap0) (RawSnapshotLayer -> Maybe WantedCompiler
rslCompiler RawSnapshotLayer
rsl)
            , snapshotPackages :: Map PackageName SnapshotPackage
snapshotPackages = Map PackageName SnapshotPackage
packages
            , snapshotDrop :: Set PackageName
snapshotDrop = AddPackagesConfig -> Set PackageName
apcDrop AddPackagesConfig
unused
            }
      (Snapshot, [CompletedSL], [CompletedPLI])
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Snapshot
snapshot, CompletedSL
sloc CompletedSL -> [CompletedSL] -> [CompletedSL]
forall a. a -> [a] -> [a]
: [CompletedSL]
slocs,[CompletedPLI]
completed0 [CompletedPLI] -> [CompletedPLI] -> [CompletedPLI]
forall a. [a] -> [a] -> [a]
++ [CompletedPLI]
completed)

data SingleOrNot a
  = Single !a
  | Multiple !a !a !([a] -> [a])

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

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

-- | Package settings to be passed to 'addPackagesToSnapshot'.

--

-- @since 0.1.0.0

data AddPackagesConfig = AddPackagesConfig
  { AddPackagesConfig -> Set PackageName
apcDrop :: !(Set PackageName)
  , AddPackagesConfig -> Map PackageName (Map FlagName Bool)
apcFlags :: !(Map PackageName (Map FlagName Bool))
  , AddPackagesConfig -> Map PackageName Bool
apcHiddens :: !(Map PackageName Bool)
  , AddPackagesConfig -> Map PackageName [Text]
apcGhcOptions :: !(Map PackageName [Text])
  }

-- | Does not warn about drops, those are allowed in order to ignore global

-- packages.

warnUnusedAddPackagesConfig ::
     HasLogFunc env
  => Utf8Builder -- ^ source

  -> AddPackagesConfig
  -> RIO env ()
warnUnusedAddPackagesConfig :: 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
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Utf8Builder] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Utf8Builder]
ls) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
    Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Some warnings discovered when adding packages to snapshot (" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
source Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
")"
    (Utf8Builder -> RIO env ()) -> [Utf8Builder] -> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn [Utf8Builder]
ls
 where
  ls :: [Utf8Builder]
ls = [[Utf8Builder]] -> [Utf8Builder]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Utf8Builder]
flags', [Utf8Builder]
hiddens', [Utf8Builder]
options']

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

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

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

-- | Add more packages to a snapshot

--

-- Note that any settings on a parent flag which is being replaced will be

-- ignored. For example, if package @foo@ is in the parent and has flag @bar@

-- set, and @foo@ also appears in new packages, then @bar@ will no longer be

-- set.

--

-- Returns any of the 'AddPackagesConfig' values not used.

--

-- @since 0.1.0.0

addPackagesToSnapshot ::
     (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => Utf8Builder
     -- ^ Text description of where these new packages are coming from, for

     -- error messages only

  -> [RawPackageLocationImmutable] -- ^ new packages

  -> AddPackagesConfig
  -> Map PackageName RawSnapshotPackage -- ^ packages from parent

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

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

  (Map PackageName RawSnapshotPackage, AddPackagesConfig)
-> RIO env (Map PackageName RawSnapshotPackage, AddPackagesConfig)
forall a. a -> RIO env a
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 = MaybeT (RIO env) PackageLocationImmutable
-> RIO env (Maybe PackageLocationImmutable)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (RIO env) PackageLocationImmutable
 -> RIO env (Maybe PackageLocationImmutable))
-> MaybeT (RIO env) PackageLocationImmutable
-> RIO env (Maybe PackageLocationImmutable)
forall a b. (a -> b) -> a -> b
$
  MaybeT (RIO env) PackageLocationImmutable
tryCache MaybeT (RIO env) PackageLocationImmutable
-> MaybeT (RIO env) PackageLocationImmutable
-> MaybeT (RIO env) PackageLocationImmutable
forall a.
MaybeT (RIO env) a -> MaybeT (RIO env) a -> MaybeT (RIO env) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MaybeT (RIO env) PackageLocationImmutable
tryCpl
 where
  tryCache :: MaybeT (RIO env) PackageLocationImmutable
tryCache = Maybe PackageLocationImmutable
-> MaybeT (RIO env) PackageLocationImmutable
forall (m :: * -> *) b. Applicative m => Maybe b -> MaybeT m b
hoistMaybe (Maybe PackageLocationImmutable
 -> MaybeT (RIO env) PackageLocationImmutable)
-> Maybe PackageLocationImmutable
-> MaybeT (RIO env) PackageLocationImmutable
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> Maybe PackageLocationImmutable
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RawPackageLocationImmutable
rpli Map RawPackageLocationImmutable PackageLocationImmutable
cachePackages
  tryCpl :: MaybeT (RIO env) PackageLocationImmutable
tryCpl = do
    CompletePackageLocation
cpl <- RIO env CompletePackageLocation
-> MaybeT (RIO env) CompletePackageLocation
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RIO env CompletePackageLocation
 -> MaybeT (RIO env) CompletePackageLocation)
-> RIO env CompletePackageLocation
-> MaybeT (RIO env) CompletePackageLocation
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable -> RIO env CompletePackageLocation
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env CompletePackageLocation
completePackageLocation RawPackageLocationImmutable
rpli
    if CompletePackageLocation -> Bool
cplHasCabalFile CompletePackageLocation
cpl then PackageLocationImmutable
-> MaybeT (RIO env) PackageLocationImmutable
forall a. a -> MaybeT (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CompletePackageLocation -> PackageLocationImmutable
cplComplete CompletePackageLocation
cpl) else MaybeT (RIO env) PackageLocationImmutable
forall a. MaybeT (RIO env) a
forall (f :: * -> *) a. Alternative f => f a
empty

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

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

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

-- | Parse a 'SnapshotLayer' value from a 'SnapshotLocation'.

--

-- Returns a 'Left' value if provided an 'SLCompiler' constructor. Otherwise,

-- returns a 'Right' value providing both the 'Snapshot' and a hash of the input

-- configuration file.

--

-- @since 0.1.0.0

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

-- | Parse a 'SnapshotLayer' value from a 'SnapshotLocation'.

--

-- Returns a 'Left' value if provided an 'SLCompiler' constructor. Otherwise,

-- returns a 'Right' value providing both the 'Snapshot' and a hash of the input

-- configuration file.

--

-- @since 0.1.0.0

loadSnapshotLayer ::
     (HasPantryConfig env, HasLogFunc env)
  => SnapshotLocation
  -> RIO env (Either WantedCompiler RawSnapshotLayer)
loadSnapshotLayer :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
SnapshotLocation
-> RIO env (Either WantedCompiler RawSnapshotLayer)
loadSnapshotLayer (SLCompiler WantedCompiler
compiler) = Either WantedCompiler RawSnapshotLayer
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either WantedCompiler RawSnapshotLayer
 -> RIO env (Either WantedCompiler RawSnapshotLayer))
-> Either WantedCompiler RawSnapshotLayer
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall a b. (a -> b) -> a -> b
$ WantedCompiler -> Either WantedCompiler RawSnapshotLayer
forall a b. a -> Either a b
Left WantedCompiler
compiler
loadSnapshotLayer sl :: SnapshotLocation
sl@(SLUrl Text
url BlobKey
blob) =
  (SomeException -> RIO env (Either WantedCompiler RawSnapshotLayer))
-> RIO env (Either WantedCompiler RawSnapshotLayer)
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny (PantryException -> RIO env (Either WantedCompiler RawSnapshotLayer)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException
 -> RIO env (Either WantedCompiler RawSnapshotLayer))
-> (SomeException -> PantryException)
-> SomeException
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSnapshotLocation -> SomeException -> PantryException
InvalidSnapshot (SnapshotLocation -> RawSnapshotLocation
toRawSL SnapshotLocation
sl)) (RIO env (Either WantedCompiler RawSnapshotLayer)
 -> RIO env (Either WantedCompiler RawSnapshotLayer))
-> RIO env (Either WantedCompiler RawSnapshotLayer)
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall a b. (a -> b) -> a -> b
$ do
    ByteString
bs <- Text -> Maybe BlobKey -> RIO env ByteString
forall env.
(HasPantryConfig env, HasLogFunc env) =>
Text -> Maybe BlobKey -> RIO env ByteString
loadFromURL Text
url (BlobKey -> Maybe BlobKey
forall a. a -> Maybe a
Just BlobKey
blob)
    Value
value <- ByteString -> RIO env Value
forall (m :: * -> *) a.
(MonadThrow m, FromJSON a) =>
ByteString -> m a
Yaml.decodeThrow ByteString
bs
    RawSnapshotLayer
snapshot <- SnapshotLocation
-> Value -> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
forall env.
HasLogFunc env =>
SnapshotLocation
-> Value -> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
warningsParserHelper SnapshotLocation
sl Value
value Maybe (Path Abs Dir)
forall a. Maybe a
Nothing
    Either WantedCompiler RawSnapshotLayer
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either WantedCompiler RawSnapshotLayer
 -> RIO env (Either WantedCompiler RawSnapshotLayer))
-> Either WantedCompiler RawSnapshotLayer
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall a b. (a -> b) -> a -> b
$ RawSnapshotLayer -> Either WantedCompiler RawSnapshotLayer
forall a b. b -> Either a b
Right RawSnapshotLayer
snapshot
loadSnapshotLayer sl :: SnapshotLocation
sl@(SLFilePath ResolvedPath File
fp) =
  (SomeException -> RIO env (Either WantedCompiler RawSnapshotLayer))
-> RIO env (Either WantedCompiler RawSnapshotLayer)
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny (PantryException -> RIO env (Either WantedCompiler RawSnapshotLayer)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException
 -> RIO env (Either WantedCompiler RawSnapshotLayer))
-> (SomeException -> PantryException)
-> SomeException
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSnapshotLocation -> SomeException -> PantryException
InvalidSnapshot (SnapshotLocation -> RawSnapshotLocation
toRawSL SnapshotLocation
sl)) (RIO env (Either WantedCompiler RawSnapshotLayer)
 -> RIO env (Either WantedCompiler RawSnapshotLayer))
-> RIO env (Either WantedCompiler RawSnapshotLayer)
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall a b. (a -> b) -> a -> b
$ do
    Value
value <- String -> RIO env Value
forall (m :: * -> *) a. (MonadIO m, FromJSON a) => String -> m a
Yaml.decodeFileThrow (String -> RIO env Value) -> String -> RIO env Value
forall a b. (a -> b) -> a -> b
$ Path Abs File -> String
forall b t. Path b t -> String
toFilePath (Path Abs File -> String) -> Path Abs File -> String
forall a b. (a -> b) -> a -> b
$ ResolvedPath File -> Path Abs File
forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath File
fp
    RawSnapshotLayer
snapshot <- SnapshotLocation
-> Value -> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
forall env.
HasLogFunc env =>
SnapshotLocation
-> Value -> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
warningsParserHelper SnapshotLocation
sl Value
value (Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer)
-> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> Maybe (Path Abs Dir)
forall a. a -> Maybe a
Just (Path Abs Dir -> Maybe (Path Abs Dir))
-> Path Abs Dir -> Maybe (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent (Path Abs File -> Path Abs Dir) -> Path Abs File -> Path Abs Dir
forall a b. (a -> b) -> a -> b
$ ResolvedPath File -> Path Abs File
forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath File
fp
    Either WantedCompiler RawSnapshotLayer
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either WantedCompiler RawSnapshotLayer
 -> RIO env (Either WantedCompiler RawSnapshotLayer))
-> Either WantedCompiler RawSnapshotLayer
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall a b. (a -> b) -> a -> b
$ RawSnapshotLayer -> Either WantedCompiler RawSnapshotLayer
forall a b. b -> Either a b
Right RawSnapshotLayer
snapshot

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

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

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

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

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

  -> Maybe BlobKey
  -> RIO env ByteString
loadWithCheck :: 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 -> (Maybe SHA256
forall a. Maybe a
Nothing, Maybe FileSize
forall a. Maybe a
Nothing)
          Just (BlobKey SHA256
sha FileSize
size) -> (SHA256 -> Maybe SHA256
forall a. a -> Maybe a
Just SHA256
sha, FileSize -> Maybe FileSize
forall a. a -> Maybe a
Just FileSize
size)
  (SHA256
_, FileSize
_, [ByteString]
bss) <- Text
-> Maybe SHA256
-> Maybe FileSize
-> ConduitT ByteString Void (RIO env) [ByteString]
-> RIO env (SHA256, FileSize, [ByteString])
forall (m :: * -> *) a.
MonadUnliftIO m =>
Text
-> Maybe SHA256
-> Maybe FileSize
-> ConduitT ByteString Void m a
-> m (SHA256, FileSize, a)
httpSinkChecked Text
url Maybe SHA256
msha Maybe FileSize
msize ConduitT ByteString Void (RIO env) [ByteString]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
sinkList
  let bs :: ByteString
bs = [ByteString] -> ByteString
B.concat [ByteString]
bss
  ReaderT SqlBackend (RIO env) () -> RIO env ()
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) () -> RIO env ())
-> ReaderT SqlBackend (RIO env) () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Text -> ByteString -> ReaderT SqlBackend (RIO env) ()
forall env. Text -> ByteString -> ReaderT SqlBackend (RIO env) ()
storeURLBlob Text
url ByteString
bs
  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Loaded snapshot from third party: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
url)
  ByteString -> RIO env ByteString
forall a. a -> RIO env a
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 (Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLayer)))
-> Value
-> Either String (WithJSONWarnings (Unresolved RawSnapshotLayer))
forall a b. (a -> Parser b) -> a -> Either String b
parseEither Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLayer))
forall a. FromJSON a => Value -> Parser a
Yaml.parseJSON Value
val of
    Left String
e -> PantryException -> RIO env RawSnapshotLayer
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env RawSnapshotLayer)
-> PantryException -> RIO env RawSnapshotLayer
forall a b. (a -> b) -> a -> b
$ RawSnapshotLocation -> String -> PantryException
Couldn'tParseSnapshot RawSnapshotLocation
rsl String
e
    Right (WithJSONWarnings Unresolved RawSnapshotLayer
x [JSONWarning]
ws) -> do
      Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([JSONWarning] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [JSONWarning]
ws) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
        Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Warnings when parsing snapshot " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> RawSnapshotLocation -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
rsl
        [JSONWarning] -> (JSONWarning -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [JSONWarning]
ws ((JSONWarning -> RIO env ()) -> RIO env ())
-> (JSONWarning -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ())
-> (JSONWarning -> Utf8Builder) -> JSONWarning -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSONWarning -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display
      Maybe (Path Abs Dir)
-> Unresolved RawSnapshotLayer -> RIO env RawSnapshotLayer
forall (m :: * -> *) a.
MonadIO m =>
Maybe (Path Abs Dir) -> Unresolved a -> m a
resolvePaths Maybe (Path Abs Dir)
mdir Unresolved RawSnapshotLayer
x

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

-- | Get the 'PackageName' of the package at the given location.

--

-- @since 0.1.0.0

getPackageLocationName ::
     (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => RawPackageLocationImmutable
  -> RIO env PackageName
getPackageLocationName :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env PackageName
getPackageLocationName = (PackageIdentifier -> PackageName)
-> RIO env PackageIdentifier -> RIO env PackageName
forall a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageIdentifier -> PackageName
pkgName (RIO env PackageIdentifier -> RIO env PackageName)
-> (RawPackageLocationImmutable -> RIO env PackageIdentifier)
-> RawPackageLocationImmutable
-> RIO env PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawPackageLocationImmutable -> RIO env PackageIdentifier
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env PackageIdentifier
getRawPackageLocationIdent

-- | Get the 'PackageIdentifier' of the package at the given location.

--

-- @since 0.1.0.0

packageLocationIdent ::
     PackageLocationImmutable
  -> PackageIdentifier
packageLocationIdent :: PackageLocationImmutable -> PackageIdentifier
packageLocationIdent (PLIHackage PackageIdentifier
ident BlobKey
_ TreeKey
_) = PackageIdentifier
ident
packageLocationIdent (PLIRepo Repo
_ PackageMetadata
pm) = PackageMetadata -> PackageIdentifier
pmIdent PackageMetadata
pm
packageLocationIdent (PLIArchive Archive
_ PackageMetadata
pm) = PackageMetadata -> PackageIdentifier
pmIdent PackageMetadata
pm

-- | Get version of the package at the given location.

--

-- @since 0.1.0.0

packageLocationVersion ::
     PackageLocationImmutable
  -> Version
packageLocationVersion :: PackageLocationImmutable -> Version
packageLocationVersion (PLIHackage PackageIdentifier
pident BlobKey
_ TreeKey
_) = PackageIdentifier -> Version
pkgVersion PackageIdentifier
pident
packageLocationVersion (PLIRepo Repo
_ PackageMetadata
pm) = PackageIdentifier -> Version
pkgVersion (PackageMetadata -> PackageIdentifier
pmIdent PackageMetadata
pm)
packageLocationVersion (PLIArchive Archive
_ PackageMetadata
pm) = PackageIdentifier -> Version
pkgVersion (PackageMetadata -> PackageIdentifier
pmIdent PackageMetadata
pm)

-- | Get the 'PackageIdentifier' of the package at the given location.

--

-- @since 0.1.0.0

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

-- | Get the 'TreeKey' of the package at the given location.

--

-- @since 0.1.0.0

getRawPackageLocationTreeKey
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => RawPackageLocationImmutable
  -> RIO env TreeKey
getRawPackageLocationTreeKey :: 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' -> TreeKey -> RIO env TreeKey
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TreeKey
treeKey'
    Maybe TreeKey
Nothing ->
      case RawPackageLocationImmutable
pl of
        RPLIHackage PackageIdentifierRevision
pir Maybe TreeKey
_ -> PackageIdentifierRevision -> RIO env TreeKey
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageIdentifierRevision -> RIO env TreeKey
getHackageTarballKey PackageIdentifierRevision
pir
        RPLIArchive RawArchive
archive RawPackageMetadata
pm -> RawPackageLocationImmutable
-> RawArchive -> RawPackageMetadata -> RIO env TreeKey
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> RawArchive -> RawPackageMetadata -> RIO env TreeKey
getArchiveKey RawPackageLocationImmutable
pl RawArchive
archive RawPackageMetadata
pm
        RPLIRepo Repo
repo RawPackageMetadata
pm -> Repo -> RawPackageMetadata -> RIO env TreeKey
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Repo -> RawPackageMetadata -> RIO env TreeKey
getRepoKey Repo
repo RawPackageMetadata
pm

-- | Get the 'TreeKey' of the package at the given location.

--

-- @since 0.1.0.0

getPackageLocationTreeKey
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => PackageLocationImmutable
  -> RIO env TreeKey
getPackageLocationTreeKey :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageLocationImmutable -> RIO env TreeKey
getPackageLocationTreeKey PackageLocationImmutable
pl = TreeKey -> RIO env TreeKey
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TreeKey -> RIO env TreeKey) -> TreeKey -> RIO env TreeKey
forall a b. (a -> b) -> a -> b
$ PackageLocationImmutable -> TreeKey
getTreeKey PackageLocationImmutable
pl

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

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

-- | Convenient data type that allows you to work with pantry more easily than

-- using 'withPantryConfig' or 'withPantryConfig'' directly. Uses basically sane

-- settings, like sharing a pantry directory with Stack.

--

-- You can use 'runPantryApp' to use this. A simple example is:

--

-- > {-# LANGUAGE OverloadedStrings #-}

-- >

-- > module Main (main) where

-- >

-- > -- From package Cabal-syntax

-- > import Distribution.Types.Version ( mkVersion )

-- > -- From package pantry

-- > import Pantry

-- >          ( CabalFileInfo (..), PackageIdentifierRevision (..), PantryApp

-- >          , RawPackageLocationImmutable (..), loadPackageRaw, runPantryApp

-- >          )

-- > -- From package rio

-- > import RIO ( RIO, liftIO )

-- >

-- > main :: IO ()

-- > main = runPantryApp myPantryApp

-- >

-- > myPantryApp :: RIO PantryApp ()

-- > myPantryApp = loadPackageRaw baseLocation >>= liftIO . print

-- >  where

-- >   baseVersion = mkVersion [4, 19, 0, 0]

-- >   basePkgId = PackageIdentifierRevision "base" baseVersion CFILatest

-- >   baseLocation = RPLIHackage basePkgId Nothing

--

-- @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 = (PantryApp -> SimpleApp)
-> (PantryApp -> SimpleApp -> PantryApp)
-> Lens' PantryApp SimpleApp
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens PantryApp -> SimpleApp
paSimpleApp (\PantryApp
x SimpleApp
y -> PantryApp
x { paSimpleApp = 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 =
  (HpackExecutable -> PantryConfig)
-> f HpackExecutable -> f PantryConfig
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\HpackExecutable
hpExe -> PantryConfig
pconfig { pcHpackExecutable = hpExe }) (HpackExecutable -> f HpackExecutable
k (PantryConfig -> HpackExecutable
pcHpackExecutable PantryConfig
pconfig))

-- | Lens to view or modify the 'Hpack.Force' of a 'PantryConfig'.

--

-- @since 0.10.0

hpackForceL :: Lens' PantryConfig Hpack.Force
hpackForceL :: Lens' PantryConfig Force
hpackForceL Force -> f Force
k PantryConfig
pconfig =
  (Force -> PantryConfig) -> f Force -> f PantryConfig
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
    (\Force
hpackForce -> PantryConfig
pconfig { pcHpackForce = hpackForce })
    (Force -> f Force
k (PantryConfig -> Force
pcHpackForce PantryConfig
pconfig))

instance HasLogFunc PantryApp where
  logFuncL :: Lens' PantryApp LogFunc
logFuncL = (SimpleApp -> f SimpleApp) -> PantryApp -> f PantryApp
Lens' PantryApp SimpleApp
simpleAppL((SimpleApp -> f SimpleApp) -> PantryApp -> f PantryApp)
-> ((LogFunc -> f LogFunc) -> SimpleApp -> f SimpleApp)
-> (LogFunc -> f LogFunc)
-> PantryApp
-> f PantryApp
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(LogFunc -> f LogFunc) -> SimpleApp -> f SimpleApp
forall env. HasLogFunc env => Lens' env LogFunc
Lens' SimpleApp LogFunc
logFuncL

instance HasPantryConfig PantryApp where
  pantryConfigL :: Lens' PantryApp PantryConfig
pantryConfigL = (PantryApp -> PantryConfig)
-> (PantryApp -> PantryConfig -> PantryApp)
-> Lens' PantryApp PantryConfig
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens PantryApp -> PantryConfig
paPantryConfig (\PantryApp
x PantryConfig
y -> PantryApp
x { paPantryConfig = y })

instance HasProcessContext PantryApp where
  processContextL :: Lens' PantryApp ProcessContext
processContextL = (SimpleApp -> f SimpleApp) -> PantryApp -> f PantryApp
Lens' PantryApp SimpleApp
simpleAppL((SimpleApp -> f SimpleApp) -> PantryApp -> f PantryApp)
-> ((ProcessContext -> f ProcessContext)
    -> SimpleApp -> f SimpleApp)
-> (ProcessContext -> f ProcessContext)
-> PantryApp
-> f PantryApp
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ProcessContext -> f ProcessContext) -> SimpleApp -> f SimpleApp
forall env. HasProcessContext env => Lens' env ProcessContext
Lens' SimpleApp ProcessContext
processContextL

instance HasStylesUpdate PantryApp where
  stylesUpdateL :: Lens' PantryApp StylesUpdate
stylesUpdateL = (PantryApp -> StylesUpdate)
-> (PantryApp -> StylesUpdate -> PantryApp)
-> Lens' PantryApp StylesUpdate
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens PantryApp -> StylesUpdate
paStylesUpdate (\PantryApp
x StylesUpdate
y -> PantryApp
x { paStylesUpdate = y })

instance HasTerm PantryApp where
  useColorL :: Lens' PantryApp Bool
useColorL = (PantryApp -> Bool)
-> (PantryApp -> Bool -> PantryApp) -> Lens' PantryApp Bool
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens PantryApp -> Bool
paUseColor (\PantryApp
x Bool
y -> PantryApp
x { paUseColor = y })
  termWidthL :: Lens' PantryApp Int
termWidthL = (PantryApp -> Int)
-> (PantryApp -> Int -> PantryApp) -> Lens' PantryApp Int
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens PantryApp -> Int
paTermWidth  (\PantryApp
x Int
y -> PantryApp
x { paTermWidth = 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 = Int -> CasaRepoPrefix -> Int -> RIO PantryApp a -> m a
forall (m :: * -> *) a.
MonadIO m =>
Int -> CasaRepoPrefix -> Int -> RIO PantryApp a -> m a
runPantryAppWith Int
8 CasaRepoPrefix
defaultCasaRepoPrefix Int
defaultCasaMaxPerRequest

-- | Run some code against pantry using basic sane settings.

--

-- For testing, see 'runPantryAppClean'.

--

-- @since 0.1.1.1

runPantryAppWith ::
     MonadIO m
  => Int
  -> CasaRepoPrefix
  -> Int
  -> RIO PantryApp a
  -> m a
runPantryAppWith :: forall (m :: * -> *) a.
MonadIO m =>
Int -> CasaRepoPrefix -> Int -> RIO PantryApp a -> m a
runPantryAppWith Int
maxConnCount CasaRepoPrefix
casaRepoPrefix Int
casaMaxPerRequest RIO PantryApp a
f = RIO SimpleApp a -> m a
forall (m :: * -> *) a. MonadIO m => RIO SimpleApp a -> m a
runSimpleApp (RIO SimpleApp a -> m a) -> RIO SimpleApp a -> m a
forall a b. (a -> b) -> a -> b
$ do
  SimpleApp
sa <- RIO SimpleApp SimpleApp
forall r (m :: * -> *). MonadReader r m => m r
ask
  String
stack <- String -> RIO SimpleApp String
forall (m :: * -> *). MonadIO m => String -> m String
getAppUserDataDirectory String
"stack"
  Path Abs Dir
root <- String -> RIO SimpleApp (Path Abs Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs Dir)
parseAbsDir (String -> RIO SimpleApp (Path Abs Dir))
-> String -> RIO SimpleApp (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ String
stack String -> String -> String
FilePath.</> String
"pantry"
  Path Abs Dir
-> PackageIndexConfig
-> HpackExecutable
-> Force
-> Int
-> Maybe (CasaRepoPrefix, Int)
-> (SnapName -> RawSnapshotLocation)
-> (WantedCompiler -> GlobalHintsLocation)
-> (PantryConfig -> RIO SimpleApp a)
-> RIO SimpleApp a
forall env a.
HasLogFunc env =>
Path Abs Dir
-> PackageIndexConfig
-> HpackExecutable
-> Force
-> Int
-> Maybe (CasaRepoPrefix, Int)
-> (SnapName -> RawSnapshotLocation)
-> (WantedCompiler -> GlobalHintsLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
withPantryConfig'
    Path Abs Dir
root
    PackageIndexConfig
defaultPackageIndexConfig
    HpackExecutable
HpackBundled
    Force
Hpack.NoForce
    Int
maxConnCount
    ((CasaRepoPrefix, Int) -> Maybe (CasaRepoPrefix, Int)
forall a. a -> Maybe a
Just (CasaRepoPrefix
casaRepoPrefix, Int
casaMaxPerRequest))
    SnapName -> RawSnapshotLocation
defaultSnapshotLocation
    WantedCompiler -> GlobalHintsLocation
defaultGlobalHintsLocation
    ((PantryConfig -> RIO SimpleApp a) -> RIO SimpleApp a)
-> (PantryConfig -> RIO SimpleApp a) -> RIO SimpleApp a
forall a b. (a -> b) -> a -> b
$ \PantryConfig
pc ->
      PantryApp -> RIO PantryApp a -> RIO SimpleApp a
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO
        PantryApp
          { paSimpleApp :: SimpleApp
paSimpleApp = SimpleApp
sa
          , paPantryConfig :: PantryConfig
paPantryConfig = PantryConfig
pc
          , paTermWidth :: Int
paTermWidth = Int
100
          , paUseColor :: Bool
paUseColor = Bool
True
          , paStylesUpdate :: StylesUpdate
paStylesUpdate = StylesUpdate
forall a. Monoid a => a
mempty
          }
        RIO PantryApp a
f

-- | Like 'runPantryApp', but uses an empty pantry directory instead of sharing

-- with Stack. Useful for testing.

--

-- @since 0.1.0.0

runPantryAppClean :: MonadIO m => RIO PantryApp a -> m a
runPantryAppClean :: forall (m :: * -> *) a. MonadIO m => RIO PantryApp a -> m a
runPantryAppClean RIO PantryApp a
f =
  IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ String -> (String -> IO a) -> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> (String -> m a) -> m a
withSystemTempDirectory String
"pantry-clean" ((String -> IO a) -> IO a) -> (String -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \String
dir -> RIO SimpleApp a -> IO a
forall (m :: * -> *) a. MonadIO m => RIO SimpleApp a -> m a
runSimpleApp (RIO SimpleApp a -> IO a) -> RIO SimpleApp a -> IO a
forall a b. (a -> b) -> a -> b
$ do
    SimpleApp
sa <- RIO SimpleApp SimpleApp
forall r (m :: * -> *). MonadReader r m => m r
ask
    Path Abs Dir
root <- String -> RIO SimpleApp (Path Abs Dir)
forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
resolveDir' String
dir
    Path Abs Dir
-> PackageIndexConfig
-> HpackExecutable
-> Force
-> Int
-> Maybe (CasaRepoPrefix, Int)
-> (SnapName -> RawSnapshotLocation)
-> (WantedCompiler -> GlobalHintsLocation)
-> (PantryConfig -> RIO SimpleApp a)
-> RIO SimpleApp a
forall env a.
HasLogFunc env =>
Path Abs Dir
-> PackageIndexConfig
-> HpackExecutable
-> Force
-> Int
-> Maybe (CasaRepoPrefix, Int)
-> (SnapName -> RawSnapshotLocation)
-> (WantedCompiler -> GlobalHintsLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
withPantryConfig'
      Path Abs Dir
root
      PackageIndexConfig
defaultPackageIndexConfig
      HpackExecutable
HpackBundled
      Force
Hpack.NoForce
      Int
8
      ((CasaRepoPrefix, Int) -> Maybe (CasaRepoPrefix, Int)
forall a. a -> Maybe a
Just (CasaRepoPrefix
defaultCasaRepoPrefix, Int
defaultCasaMaxPerRequest))
      SnapName -> RawSnapshotLocation
defaultSnapshotLocation
      WantedCompiler -> GlobalHintsLocation
defaultGlobalHintsLocation
      ((PantryConfig -> RIO SimpleApp a) -> RIO SimpleApp a)
-> (PantryConfig -> RIO SimpleApp a) -> RIO SimpleApp a
forall a b. (a -> b) -> a -> b
$ \PantryConfig
pc ->
        PantryApp -> RIO PantryApp a -> RIO SimpleApp a
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO
          PantryApp
            { paSimpleApp :: SimpleApp
paSimpleApp = SimpleApp
sa
            , paPantryConfig :: PantryConfig
paPantryConfig = PantryConfig
pc
            , paTermWidth :: Int
paTermWidth = Int
100
            , paUseColor :: Bool
paUseColor = Bool
True
            , paStylesUpdate :: StylesUpdate
paStylesUpdate = StylesUpdate
forall a. Monoid a => a
mempty
            }
          RIO PantryApp a
f

-- | Load the global hints.

--

-- @since 9.4.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 = do
  Path Abs File
dest <- RIO env (Path Abs File)
forall env. HasPantryConfig env => RIO env (Path Abs File)
getGlobalHintsFile
  GlobalHintsLocation
loc <- WantedCompiler -> RIO env GlobalHintsLocation
forall env.
HasPantryConfig env =>
WantedCompiler -> RIO env GlobalHintsLocation
globalHintsLocation WantedCompiler
wc
  Path Abs File
-> GlobalHintsLocation
-> Bool
-> RIO env (Maybe (Map PackageName Version))
forall {a} {b} {env}.
(Ord a, IsCabalString a, IsCabalString b, HasTerm env) =>
Path Abs File
-> GlobalHintsLocation -> Bool -> RIO env (Maybe (Map a b))
inner Path Abs File
dest GlobalHintsLocation
loc Bool
False
 where
  inner :: Path Abs File
-> GlobalHintsLocation -> Bool -> RIO env (Maybe (Map a b))
inner Path Abs File
dest GlobalHintsLocation
loc Bool
alreadyDownloaded = case GlobalHintsLocation
loc of
    GHLUrl Text
url -> do
      Request
req <- String -> RIO env Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest (String -> RIO env Request) -> String -> RIO env Request
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
url
      Bool
downloaded <- Request -> Path Abs File -> RIO env Bool
forall env. HasTerm env => Request -> Path Abs File -> RIO env Bool
download Request
req Path Abs File
dest
      Maybe (Map a b)
mres <- Path Abs File -> RIO env (Maybe (Map a b))
forall {m :: * -> *} {a} {b} {env} {b} {t}.
(MonadUnliftIO m, Ord a, IsCabalString a, IsCabalString b,
 HasTerm env, MonadReader env m) =>
Path b t -> m (Maybe (Map a b))
tryParseYaml Path Abs File
dest
      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
          [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
            [ String -> StyleDoc
flow String
"Could not find local global hints for"
            , String -> StyleDoc
string (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ WantedCompiler -> Text
forall a. Display a => a -> Text
RIO.textDisplay WantedCompiler
wc) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
            , String -> StyleDoc
flow String
"forcing a redownload."
            ]
          Bool
redownloaded <- Request -> Path Abs File -> RIO env Bool
forall env. HasTerm env => Request -> Path Abs File -> RIO env Bool
redownload Request
req Path Abs File
dest
          if Bool
redownloaded
            then Path Abs File
-> GlobalHintsLocation -> Bool -> RIO env (Maybe (Map a b))
inner Path Abs File
dest GlobalHintsLocation
loc Bool
True
            else do
              Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Redownload didn't happen"
              Maybe (Map a b) -> RIO env (Maybe (Map a b))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Map a b)
forall a. Maybe a
Nothing
        Maybe (Map a b)
_ -> Maybe (Map a b) -> RIO env (Maybe (Map a b))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Map a b)
mres
    GHLFilePath ResolvedPath File
fp -> do
      let source :: Path Abs File
source = ResolvedPath File -> Path Abs File
forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath File
fp
      Maybe (Map a b)
mres <- Path Abs File -> RIO env (Maybe (Map a b))
forall {m :: * -> *} {a} {b} {env} {b} {t}.
(MonadUnliftIO m, Ord a, IsCabalString a, IsCabalString b,
 HasTerm env, MonadReader env m) =>
Path b t -> m (Maybe (Map a b))
tryParseYaml Path Abs File
source
      case Maybe (Map a b)
mres of
        Maybe (Map a b)
Nothing -> do
          [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
            [ String -> StyleDoc
flow String
"Could not find local global hints for"
            , String -> StyleDoc
string (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ WantedCompiler -> Text
forall a. Display a => a -> Text
RIO.textDisplay WantedCompiler
wc)
            , StyleDoc
"in"
            , Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
source StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
            ]
          Maybe (Map a b) -> RIO env (Maybe (Map a b))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Map a b)
forall a. Maybe a
Nothing
        Maybe (Map a b)
_ -> do
          IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Path Abs File -> IO ()
forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 File -> Path b1 File -> m ()
copyFile Path Abs File
source Path Abs File
dest
          [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyDebugL
            [ String -> StyleDoc
flow String
"Installed global hints from"
            , Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
source
            ]
          Maybe (Map a b) -> RIO env (Maybe (Map a b))
forall a. a -> RIO env a
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
fp = IO (Maybe (Map a b)) -> m (Maybe (Map a b))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Map a b)) -> m (Maybe (Map a b)))
-> IO (Maybe (Map a b)) -> m (Maybe (Map a b))
forall a b. (a -> b) -> a -> b
$ do
    Map WantedCompiler (Map (CabalString a) (CabalString b))
allGlobalHints <- String
-> IO (Map WantedCompiler (Map (CabalString a) (CabalString b)))
forall (m :: * -> *) a. (MonadIO m, FromJSON a) => String -> m a
Yaml.decodeFileThrow (Path b t -> String
forall b t. Path b t -> String
toFilePath Path b t
fp)
    let globalHints :: Maybe (Map (CabalString a) (CabalString b))
globalHints = WantedCompiler
-> Map WantedCompiler (Map (CabalString a) (CabalString b))
-> Maybe (Map (CabalString a) (CabalString b))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup WantedCompiler
wc Map WantedCompiler (Map (CabalString a) (CabalString b))
allGlobalHints
    Maybe (Map a b) -> IO (Maybe (Map a b))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Map a b) -> IO (Maybe (Map a b)))
-> Maybe (Map a b) -> IO (Maybe (Map a b))
forall a b. (a -> b) -> a -> b
$ (Map (CabalString a) (CabalString b) -> Map a b)
-> Maybe (Map (CabalString a) (CabalString b)) -> Maybe (Map a b)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CabalString b -> b) -> Map a (CabalString b) -> Map a b
forall a b. (a -> b) -> Map a a -> Map a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CabalString b -> b
forall a. CabalString a -> a
unCabalString (Map a (CabalString b) -> Map a b)
-> (Map (CabalString a) (CabalString b) -> Map a (CabalString b))
-> Map (CabalString a) (CabalString b)
-> Map a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (CabalString a) (CabalString b) -> Map a (CabalString b)
forall a v. Map (CabalString a) v -> Map a v
unCabalStringMap) Maybe (Map (CabalString a) (CabalString b))
globalHints
  tryParseYaml :: Path b t -> m (Maybe (Map a b))
tryParseYaml Path b t
fp = do
    Either SomeException (Maybe (Map a b))
eres <- m (Maybe (Map a b)) -> m (Either SomeException (Maybe (Map a b)))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (Path b t -> m (Maybe (Map a b))
forall {m :: * -> *} {a} {b} {b} {t}.
(MonadIO m, Ord a, IsCabalString a, IsCabalString b) =>
Path b t -> m (Maybe (Map a b))
inner2 Path b t
fp)
    case Either SomeException (Maybe (Map a b))
eres of
      Left SomeException
e -> do
        StyleDoc -> m ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError (StyleDoc -> m ()) -> StyleDoc -> m ()
forall a b. (a -> b) -> a -> b
$
          StyleDoc
"[S-912]"
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"Error when parsing global hints:"
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
string (SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e)
        Maybe (Map a b) -> m (Maybe (Map a b))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Map a b)
forall a. Maybe a
Nothing
      Right Maybe (Map a b)
x -> Maybe (Map a b) -> m (Maybe (Map a b))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Map a b)
x

-- | 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 =
  (State (Map PackageName [PackageName], Map PackageName a) [Bool]
 -> (Map PackageName [PackageName], Map PackageName a)
 -> (Map PackageName [PackageName], Map PackageName a))
-> (Map PackageName [PackageName], Map PackageName a)
-> State (Map PackageName [PackageName], Map PackageName a) [Bool]
-> (Map PackageName [PackageName], Map PackageName a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State (Map PackageName [PackageName], Map PackageName a) [Bool]
-> (Map PackageName [PackageName], Map PackageName a)
-> (Map PackageName [PackageName], Map PackageName a)
forall s a. State s a -> s -> s
execState (Map PackageName [PackageName]
forall {a}. Map PackageName [a]
replaced, Map PackageName a
forall a. Monoid a => a
mempty) (State (Map PackageName [PackageName], Map PackageName a) [Bool]
 -> (Map PackageName [PackageName], Map PackageName a))
-> State (Map PackageName [PackageName], Map PackageName a) [Bool]
-> (Map PackageName [PackageName], Map PackageName a)
forall a b. (a -> b) -> a -> b
$
    [(PackageName, a)]
-> ((PackageName, a)
    -> StateT
         (Map PackageName [PackageName], Map PackageName a) Identity Bool)
-> State (Map PackageName [PackageName], Map PackageName a) [Bool]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (Map PackageName a -> [(PackageName, a)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName a
globals) (((PackageName, a)
  -> StateT
       (Map PackageName [PackageName], Map PackageName a) Identity Bool)
 -> State (Map PackageName [PackageName], Map PackageName a) [Bool])
-> ((PackageName, a)
    -> StateT
         (Map PackageName [PackageName], Map PackageName a) Identity Bool)
-> State (Map PackageName [PackageName], Map PackageName a) [Bool]
forall a b. (a -> b) -> a -> b
$ Map id a
-> (a -> PackageName)
-> (a -> [id])
-> (PackageName, a)
-> StateT
     (Map PackageName [PackageName], Map PackageName a) Identity Bool
forall id a.
Ord id =>
Map id a
-> (a -> PackageName)
-> (a -> [id])
-> (PackageName, a)
-> State (Map PackageName [PackageName], Map PackageName a) Bool
prunePackageWithDeps Map id a
globals' a -> PackageName
getName a -> [id]
getDeps
 where
  globals' :: Map id a
globals' = [(id, a)] -> Map id a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(id, a)] -> Map id a) -> [(id, a)] -> Map id a
forall a b. (a -> b) -> a -> b
$ (a -> (id, a)) -> [a] -> [(id, a)]
forall a b. (a -> b) -> [a] -> [b]
map (a -> id
getId (a -> id) -> (a -> a) -> a -> (id, a)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& a -> a
forall a. a -> a
id) (Map PackageName a -> [a]
forall k a. Map k a -> [a]
Map.elems Map PackageName a
globals)
  replaced :: Map PackageName [a]
replaced = (a -> [a]) -> Map PackageName a -> Map PackageName [a]
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ([a] -> a -> [a]
forall a b. a -> b -> a
const []) (Map PackageName a -> Map PackageName [a])
-> Map PackageName a -> Map PackageName [a]
forall a b. (a -> b) -> a -> b
$ Map PackageName a -> Set PackageName -> Map PackageName a
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map PackageName a
globals Set PackageName
overrides

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

-- | Use a snapshot cache, which caches which modules are in which packages in a

-- given snapshot. This is mostly intended for usage by Stack.

--

-- @since 0.1.0.0

withSnapshotCache ::
     (HasPantryConfig env, HasLogFunc env)
  => SnapshotCacheHash
  -> RIO env (Map PackageName (Set ModuleName))
  -> ((ModuleName -> RIO env [PackageName]) -> RIO env a)
  -> RIO env a
withSnapshotCache :: 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 <- ReaderT SqlBackend (RIO env) (Maybe SnapshotCacheId)
-> RIO env (Maybe SnapshotCacheId)
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) (Maybe SnapshotCacheId)
 -> RIO env (Maybe SnapshotCacheId))
-> ReaderT SqlBackend (RIO env) (Maybe SnapshotCacheId)
-> RIO env (Maybe SnapshotCacheId)
forall a b. (a -> b) -> a -> b
$ SnapshotCacheHash
-> ReaderT SqlBackend (RIO env) (Maybe SnapshotCacheId)
forall env.
SnapshotCacheHash
-> ReaderT SqlBackend (RIO env) (Maybe SnapshotCacheId)
getSnapshotCacheByHash SnapshotCacheHash
hash
  SnapshotCacheId
cacheId <- case Maybe SnapshotCacheId
mres of
    Maybe SnapshotCacheId
Nothing -> do
      Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Populating snapshot module name cache"
      Map PackageName (Set ModuleName)
packageModules <- RIO env (Map PackageName (Set ModuleName))
getModuleMapping
      ReaderT SqlBackend (RIO env) SnapshotCacheId
-> RIO env SnapshotCacheId
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) SnapshotCacheId
 -> RIO env SnapshotCacheId)
-> ReaderT SqlBackend (RIO env) SnapshotCacheId
-> RIO env SnapshotCacheId
forall a b. (a -> b) -> a -> b
$ do
        SnapshotCacheId
scId <- SnapshotCacheHash -> ReaderT SqlBackend (RIO env) SnapshotCacheId
forall env.
SnapshotCacheHash -> ReaderT SqlBackend (RIO env) SnapshotCacheId
getSnapshotCacheId SnapshotCacheHash
hash
        SnapshotCacheId
-> Map PackageName (Set ModuleName)
-> ReaderT SqlBackend (RIO env) ()
forall env.
SnapshotCacheId
-> Map PackageName (Set ModuleName)
-> ReaderT SqlBackend (RIO env) ()
storeSnapshotModuleCache SnapshotCacheId
scId Map PackageName (Set ModuleName)
packageModules
        SnapshotCacheId -> ReaderT SqlBackend (RIO env) SnapshotCacheId
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SnapshotCacheId
scId
    Just SnapshotCacheId
scId -> SnapshotCacheId -> RIO env SnapshotCacheId
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SnapshotCacheId
scId
  (ModuleName -> RIO env [PackageName]) -> RIO env a
f ((ModuleName -> RIO env [PackageName]) -> RIO env a)
-> (ModuleName -> RIO env [PackageName]) -> RIO env a
forall a b. (a -> b) -> a -> b
$ ReaderT SqlBackend (RIO env) [PackageName] -> RIO env [PackageName]
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) [PackageName]
 -> RIO env [PackageName])
-> (ModuleName -> ReaderT SqlBackend (RIO env) [PackageName])
-> ModuleName
-> RIO env [PackageName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapshotCacheId
-> ModuleName -> ReaderT SqlBackend (RIO env) [PackageName]
forall env.
SnapshotCacheId
-> ModuleName -> ReaderT SqlBackend (RIO env) [PackageName]
loadExposedModulePackages SnapshotCacheId
cacheId

-- | Add an s to the builder if n!=1.

plural :: Int -> Utf8Builder -> Utf8Builder
plural :: Int -> Utf8Builder -> Utf8Builder
plural Int
n Utf8Builder
text =
     Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Int
n
  Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" "
  Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
text
  Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> (if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
       then Utf8Builder
""
       else Utf8Builder
"s")