{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Content addressable Haskell package management, providing for

-- secure, reproducible acquisition of Haskell package contents and

-- metadata.

--

-- @since 0.1.0.0

module Pantry
  ( -- * Running

    PantryConfig
  , PackageIndexConfig (..)
  , HackageSecurityConfig (..)
  , defaultPackageIndexConfig
  , defaultDownloadPrefix
  , defaultHackageSecurityConfig
  , defaultCasaRepoPrefix
  , defaultCasaMaxPerRequest
  , defaultSnapshotLocation
  , HasPantryConfig (..)
  , withPantryConfig
  , HpackExecutable (..)

    -- ** Convenience

  , PantryApp
  , runPantryApp
  , runPantryAppClean
  , runPantryAppWith
  , hpackExecutableL

    -- * Types


    -- ** Exceptions

  , PantryException (..)

    -- ** Cabal types

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

    -- ** Files

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

    -- ** Cryptography

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

    -- ** Packages

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

    -- ** Hackage

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

    -- ** Archives

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

    -- ** Repos

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

    -- ** Package location

  , RawPackageLocation (..)
  , PackageLocation (..)
  , toRawPL
  , RawPackageLocationImmutable (..)
  , PackageLocationImmutable (..)

    -- ** Snapshots

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

    -- * Loading values

  , resolvePaths
  , loadPackageRaw
  , tryLoadPackageRawViaCasa
  , loadPackage
  , loadRawSnapshotLayer
  , loadSnapshotLayer
  , loadSnapshot
  , loadAndCompleteSnapshot
  , loadAndCompleteSnapshot'
  , loadAndCompleteSnapshotRaw
  , loadAndCompleteSnapshotRaw'
  , CompletedSL (..)
  , CompletedPLI (..)
  , addPackagesToSnapshot
  , AddPackagesConfig (..)

    -- * Completion functions

  , CompletePackageLocation (..)
  , completePackageLocation
  , completeSnapshotLocation
  , warnMissingCabalFile

    -- * Parsers

  , parseWantedCompiler
  , parseSnapName
  , parseRawSnapshotLocation
  , parsePackageIdentifierRevision
  , parseHackageText

    -- ** Cabal values

  , parsePackageIdentifier
  , parsePackageName
  , parsePackageNameThrowing
  , parseFlagName
  , parseVersion
  , parseVersionThrowing

    -- * Cabal helpers

  , packageIdentifierString
  , packageNameString
  , flagNameString
  , versionString
  , moduleNameString
  , CabalString (..)
  , toCabalStringMap
  , unCabalStringMap
  , gpdPackageIdentifier
  , gpdPackageName
  , gpdVersion

    -- * Package location

  , fetchPackages
  , unpackPackageLocationRaw
  , unpackPackageLocation
  , getPackageLocationName
  , getRawPackageLocationIdent
  , packageLocationIdent
  , packageLocationVersion
  , getRawPackageLocationTreeKey
  , getPackageLocationTreeKey

    -- * Cabal files

  , loadCabalFileRaw
  , loadCabalFile
  , loadCabalFileRawImmutable
  , loadCabalFileImmutable
  , loadCabalFilePath
  , findOrGenerateCabalFile
  , PrintWarnings (..)

    -- * Hackage index

  , updateHackageIndex
  , DidUpdateOccur (..)
  , RequireHackageIndex (..)
  , hackageIndexTarballL
  , getHackagePackageVersions
  , getLatestHackageVersion
  , getLatestHackageLocation
  , getLatestHackageRevision
  , getHackageTypoCorrections
  , loadGlobalHints
  , partitionReplacedDependencies

    -- * Snapshot cache

  , SnapshotCacheHash (..)
  , withSnapshotCache
  ) where

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

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

--

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

--

-- @since 0.1.0.0

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

  -- downloads are kept.

  -> 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.fpcomplete.com/v1/pull.

  -> Int
  -- ^ Max casa keys to pull per request.

  -> (SnapName -> RawSnapshotLocation)
  -- ^ The location of snapshot synonyms

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

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

  forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO (forall a. Monoid a => a
mempty :: LogFunc) forall a b. (a -> b) -> a -> b
$ forall env a.
HasLogFunc env =>
Path Abs File -> (Storage -> RIO env a) -> RIO env a
initStorage (Path Abs Dir
root forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
pantryRelFile) forall a b. (a -> b) -> a -> b
$ \Storage
storage -> forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO env
env forall a b. (a -> b) -> a -> b
$ do
    MVar Bool
ur <- forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar Bool
True
    IORef (Map RawPackageLocationImmutable GenericPackageDescription)
ref1 <- forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef forall a. Monoid a => a
mempty
    IORef
  (Map
     (Path Abs Dir)
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File))
ref2 <- forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef forall a. Monoid a => a
mempty
    PantryConfig -> RIO env a
inner PantryConfig
      { pcPackageIndex :: PackageIndexConfig
pcPackageIndex = PackageIndexConfig
pic
      , pcHpackExecutable :: HpackExecutable
pcHpackExecutable = HpackExecutable
he
      , pcRootDir :: Path Abs Dir
pcRootDir = Path Abs Dir
root
      , pcStorage :: Storage
pcStorage = Storage
storage
      , pcUpdateRef :: MVar Bool
pcUpdateRef = MVar Bool
ur
      , pcConnectionCount :: Int
pcConnectionCount = Int
count
      , pcParsedCabalFilesRawImmutable :: IORef (Map RawPackageLocationImmutable GenericPackageDescription)
pcParsedCabalFilesRawImmutable = IORef (Map RawPackageLocationImmutable GenericPackageDescription)
ref1
      , pcParsedCabalFilesMutable :: IORef
  (Map
     (Path Abs Dir)
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File))
pcParsedCabalFilesMutable = IORef
  (Map
     (Path Abs Dir)
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File))
ref2
      , pcCasaRepoPrefix :: CasaRepoPrefix
pcCasaRepoPrefix = CasaRepoPrefix
pullURL
      , pcCasaMaxPerRequest :: Int
pcCasaMaxPerRequest = Int
maxPerRequest
      , pcSnapshotLocation :: SnapName -> RawSnapshotLocation
pcSnapshotLocation = SnapName -> RawSnapshotLocation
snapLoc
      }

-- | Default pull URL for Casa.

--

-- @since 0.1.1.1

defaultCasaRepoPrefix :: CasaRepoPrefix
defaultCasaRepoPrefix :: CasaRepoPrefix
defaultCasaRepoPrefix = $(thParserCasaRepo "https://casa.fpcomplete.com")

-- | Default max keys to pull per request.

--

-- @since 0.1.1.1

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

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

--

-- @since 0.6.0

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

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

--

-- @since 0.6.0

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

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

-- Hackage.

--

-- @since 0.1.0.0

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

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

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

-- Hackage.

--

-- @since 0.1.0.0

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

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

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

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

-- Hackage.

--

-- @since 0.1.0.0

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

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

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

fetchTreeKeys ::
     (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => [RawPackageLocationImmutable]
  -> RIO env ()
fetchTreeKeys :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
[RawPackageLocationImmutable] -> RIO env ()
fetchTreeKeys [RawPackageLocationImmutable]
treeKeys = do
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  -- Find all tree keys that are missing from the database.

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

  -- our local database.

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

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

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

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

-- without performing any unpacking. Can be useful for build tools

-- wanting to prefetch or provide an offline mode.

--

-- @since 0.1.0.0

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

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

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

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

-- | Unpack a given 'RawPackageLocationImmutable' into the given

-- directory. Does not generate any extra subdirectories.

--

-- @since 0.1.0.0

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

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

-- | Unpack a given 'PackageLocationImmutable' into the given

-- directory. Does not generate any extra subdirectories.

--

-- @since 0.1.0.0

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

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

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

--

-- This function ignores all warnings.

--

-- @since 0.1.0.0

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

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

--

-- This function ignores all warnings.

--

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

-- these package locations. Instead, all @PackageLocationImmutable@s

-- will require a .cabal file. This may be relaxed in the future.

--

-- @since 0.1.0.0

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

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

-- 'RawPackageLocation'. Never prints warnings, see 'loadCabalFilePath'

-- for that.

--

-- @since 0.1.0.0

loadCabalFileRaw
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => RawPackageLocation
  -> RIO env GenericPackageDescription
loadCabalFileRaw :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocation -> RIO env GenericPackageDescription
loadCabalFileRaw (RPLImmutable RawPackageLocationImmutable
loc) = forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env GenericPackageDescription
loadCabalFileRawImmutable RawPackageLocationImmutable
loc
loadCabalFileRaw (RPLMutable ResolvedPath Dir
rfp) = do
  (PrintWarnings -> IO GenericPackageDescription
gpdio, PackageName
_, Path Abs File
_) <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
loadCabalFilePath (forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath Dir
rfp)
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ PrintWarnings -> IO GenericPackageDescription
gpdio PrintWarnings
NoPrintWarnings

-- | Same as 'loadCabalFileImmutable', but takes a

-- 'PackageLocation'. Never prints warnings, see 'loadCabalFilePath'

-- for that.

--

-- @since 0.1.0.0

loadCabalFile
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => PackageLocation
  -> RIO env GenericPackageDescription
loadCabalFile :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageLocation -> RIO env GenericPackageDescription
loadCabalFile (PLImmutable PackageLocationImmutable
loc) = forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageLocationImmutable -> RIO env GenericPackageDescription
loadCabalFileImmutable PackageLocationImmutable
loc
loadCabalFile (PLMutable ResolvedPath Dir
rfp) = do
  (PrintWarnings -> IO GenericPackageDescription
gpdio, PackageName
_, Path Abs File
_) <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
loadCabalFilePath (forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath Dir
rfp)
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ PrintWarnings -> IO GenericPackageDescription
gpdio PrintWarnings
NoPrintWarnings

-- | Parse the cabal file for the package inside the given

-- directory. Performs various sanity checks, such as the file name

-- being correct and having only a single cabal file.

--

-- @since 0.1.0.0

loadCabalFilePath
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => Path Abs Dir -- ^ project directory, with a cabal file or hpack file

  -> RIO env
       ( PrintWarnings -> IO GenericPackageDescription
       , PackageName
       , Path Abs File
       )
loadCabalFilePath :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir
-> RIO
     env
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File)
loadCabalFilePath Path Abs Dir
dir = do
  IORef
  (Map
     (Path Abs Dir)
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File))
ref <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig
-> IORef
     (Map
        (Path Abs Dir)
        (PrintWarnings -> IO GenericPackageDescription, PackageName,
         Path Abs File))
pcParsedCabalFilesMutable
  Maybe
  (PrintWarnings -> IO GenericPackageDescription, PackageName,
   Path Abs File)
mcached <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Path Abs Dir
dir forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef
  (Map
     (Path Abs Dir)
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File))
ref
  case Maybe
  (PrintWarnings -> IO GenericPackageDescription, PackageName,
   Path Abs File)
mcached of
    Just (PrintWarnings -> IO GenericPackageDescription, PackageName,
 Path Abs File)
triple -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (PrintWarnings -> IO GenericPackageDescription, PackageName,
 Path Abs File)
triple
    Maybe
  (PrintWarnings -> IO GenericPackageDescription, PackageName,
   Path Abs File)
Nothing -> do
      (PackageName
name, Path Abs File
cabalfp) <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir -> RIO env (PackageName, Path Abs File)
findOrGenerateCabalFile Path Abs Dir
dir
      IORef (Maybe ([PWarning], GenericPackageDescription))
gpdRef <- forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef forall a. Maybe a
Nothing
      RIO env GenericPackageDescription -> IO GenericPackageDescription
run <- forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
      let gpdio :: PrintWarnings -> IO GenericPackageDescription
gpdio = RIO env GenericPackageDescription -> IO GenericPackageDescription
run forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {m :: * -> *} {env}.
(MonadIO m, MonadThrow m, MonadReader env m, HasLogFunc env) =>
Path Abs File
-> IORef (Maybe ([PWarning], GenericPackageDescription))
-> PrintWarnings
-> m GenericPackageDescription
getGPD Path Abs File
cabalfp IORef (Maybe ([PWarning], GenericPackageDescription))
gpdRef
          triple :: (PrintWarnings -> IO GenericPackageDescription, PackageName,
 Path Abs File)
triple = (PrintWarnings -> IO GenericPackageDescription
gpdio, PackageName
name, Path Abs File
cabalfp)
      forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef
  (Map
     (Path Abs Dir)
     (PrintWarnings -> IO GenericPackageDescription, PackageName,
      Path Abs File))
ref forall a b. (a -> b) -> a -> b
$ \Map
  (Path Abs Dir)
  (PrintWarnings -> IO GenericPackageDescription, PackageName,
   Path Abs File)
m -> (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Path Abs Dir
dir (PrintWarnings -> IO GenericPackageDescription, PackageName,
 Path Abs File)
triple Map
  (Path Abs Dir)
  (PrintWarnings -> IO GenericPackageDescription, PackageName,
   Path Abs File)
m, (PrintWarnings -> IO GenericPackageDescription, PackageName,
 Path Abs File)
triple)
  where
    getGPD :: Path Abs File
-> IORef (Maybe ([PWarning], GenericPackageDescription))
-> PrintWarnings
-> m GenericPackageDescription
getGPD Path Abs File
cabalfp IORef (Maybe ([PWarning], GenericPackageDescription))
gpdRef PrintWarnings
printWarnings = do
      Maybe ([PWarning], GenericPackageDescription)
mpair <- forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Maybe ([PWarning], GenericPackageDescription))
gpdRef
      ([PWarning]
warnings0, GenericPackageDescription
gpd) <-
        case Maybe ([PWarning], GenericPackageDescription)
mpair of
          Just ([PWarning], GenericPackageDescription)
pair -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([PWarning], GenericPackageDescription)
pair
          Maybe ([PWarning], GenericPackageDescription)
Nothing -> do
            ByteString
bs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => FilePath -> m ByteString
B.readFile forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> FilePath
toFilePath Path Abs File
cabalfp
            ([PWarning]
warnings0, GenericPackageDescription
gpd) <- forall (m :: * -> *).
MonadThrow m =>
Either RawPackageLocationImmutable (Path Abs File)
-> ByteString -> m ([PWarning], GenericPackageDescription)
rawParseGPD (forall a b. b -> Either a b
Right Path Abs File
cabalfp) ByteString
bs
            forall (m :: * -> *).
MonadThrow m =>
PackageName -> Path Abs File -> m ()
checkCabalFileName (GenericPackageDescription -> PackageName
gpdPackageName GenericPackageDescription
gpd) Path Abs File
cabalfp
            forall (f :: * -> *) a. Applicative f => a -> f a
pure ([PWarning]
warnings0, GenericPackageDescription
gpd)
      [PWarning]
warnings <-
        case PrintWarnings
printWarnings of
          PrintWarnings
YesPrintWarnings -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> PWarning -> Utf8Builder
toPretty Path Abs File
cabalfp) [PWarning]
warnings0 forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> []
          PrintWarnings
NoPrintWarnings -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [PWarning]
warnings0
      forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef (Maybe ([PWarning], GenericPackageDescription))
gpdRef forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ([PWarning]
warnings, GenericPackageDescription
gpd)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure GenericPackageDescription
gpd

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

    -- | Check if the given name in the @Package@ matches the name of the .cabal file

    checkCabalFileName :: MonadThrow m => PackageName -> Path Abs File -> m ()
    checkCabalFileName :: 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 :: FilePath
expected = Text -> FilePath
T.unpack forall a b. (a -> b) -> a -> b
$ SafeFilePath -> Text
unSafeFilePath forall a b. (a -> b) -> a -> b
$ PackageName -> SafeFilePath
cabalFileName PackageName
name
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath
expected forall a. Eq a => a -> a -> Bool
/= forall b t. Path b t -> FilePath
toFilePath (forall b. Path b File -> Path Rel File
filename Path Abs File
cabalfp))
            forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Path Abs File -> PackageName -> PantryException
MismatchedCabalName Path Abs File
cabalfp PackageName
name

-- | Get the filename for the cabal file in the given directory.

--

-- If no .cabal file is present, or more than one is present, an exception is

-- thrown via 'throwM'.

--

-- If the directory contains a file named package.yaml, hpack is used to

-- generate a .cabal file from it.

--

-- @since 0.1.0.0

findOrGenerateCabalFile
    :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
    => Path Abs Dir -- ^ package directory

    -> RIO env (PackageName, Path Abs File)
findOrGenerateCabalFile :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir -> RIO env (PackageName, Path Abs File)
findOrGenerateCabalFile Path Abs Dir
pkgDir = do
    forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir -> RIO env ()
hpack Path Abs Dir
pkgDir
    [Path Abs File]
files <- forall a. (a -> Bool) -> [a] -> [a]
filter (forall a b c. (a -> b -> c) -> b -> a -> c
flip FilePath -> FilePath -> Bool
hasExtension FilePath
"cabal" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> FilePath
toFilePath) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd
         forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
pkgDir
    -- If there are multiple files, ignore files that start with

    -- ".". On unixlike environments these are hidden, and this

    -- character is not valid in package names. The main goal is

    -- to ignore emacs lock files - see

    -- https://github.com/commercialhaskell/stack/issues/1897.

    let isHidden :: FilePath -> Bool
isHidden (Char
'.':FilePath
_) = Bool
True
        isHidden FilePath
_ = Bool
False
    case forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Bool
isHidden forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> FilePath
toFilePath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. Path b File -> Path Rel File
filename) [Path Abs File]
files of
        [] -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> PantryException
NoCabalFileFound Path Abs Dir
pkgDir
        [Path Abs File
x] -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          (forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Path Abs File -> PantryException
InvalidCabalFilePath Path Abs File
x)
          (\PackageName
pn -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (PackageName
pn, Path Abs File
x)) forall a b. (a -> b) -> a -> b
$
            forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripSuffix FilePath
".cabal" (forall b t. Path b t -> FilePath
toFilePath (forall b. Path b File -> Path Rel File
filename Path Abs File
x)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
            FilePath -> Maybe PackageName
parsePackageName
        Path Abs File
_:[Path Abs File]
_ -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> [Path Abs File] -> PantryException
MultipleCabalFilesFound Path Abs Dir
pkgDir [Path Abs File]
files
      where hasExtension :: FilePath -> FilePath -> Bool
hasExtension FilePath
fp FilePath
x = FilePath -> FilePath
FilePath.takeExtension FilePath
fp forall a. Eq a => a -> a -> Bool
== FilePath
"." forall a. [a] -> [a] -> [a]
++ FilePath
x

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

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

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

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

--

-- @since 0.1.0.0

gpdPackageIdentifier :: GenericPackageDescription -> PackageIdentifier
gpdPackageIdentifier :: GenericPackageDescription -> PackageIdentifier
gpdPackageIdentifier = PackageDescription -> PackageIdentifier
D.package forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericPackageDescription -> PackageDescription
D.packageDescription

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

--

-- @since 0.1.0.0

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

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

--

-- @since 0.1.0.0

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

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

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

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

-- more efficient lookup mechanism.

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

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

-- FIXME: to be removed

loadRawCabalFileBytes
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => RawPackageLocationImmutable
  -> RIO env ByteString

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

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

-- more efficient lookup mechanism.

loadRawCabalFileBytes :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env ByteString
loadRawCabalFileBytes (RPLIHackage PackageIdentifierRevision
pir Maybe TreeKey
_mtree) = forall env.
(HasPantryConfig env, HasLogFunc env) =>
PackageIdentifierRevision -> RIO env ByteString
getHackageCabalFile PackageIdentifierRevision
pir

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

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

--

-- @since 0.1.0.0

loadPackage
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => PackageLocationImmutable
  -> RIO env Package
loadPackage :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageLocationImmutable -> RIO env Package
loadPackage = forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env Package
loadPackageRaw forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI

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

--

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

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

--

-- @since 0.1.0.0

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

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

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

-- | Maybe load the package from Casa.

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

-- | Maybe load the package from the local database.

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

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

-- is relevant to reproducibility, see

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

--

-- @since 0.4.0.0

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

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

--

-- @since 0.1.0.0

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

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

completePM
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => Repo
  -> RawPackageLocationImmutable
  -> RawPackageMetadata
  -> RIO env CompletePackageLocation
completePM :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Repo
-> RawPackageLocationImmutable
-> RawPackageMetadata
-> RIO env CompletePackageLocation
completePM Repo
repo RawPackageLocationImmutable
plOrig rpm :: RawPackageMetadata
rpm@(RawPackageMetadata Maybe PackageName
mn Maybe Version
mv Maybe TreeKey
mtk)
  | Just PackageName
n <- Maybe PackageName
mn, Just Version
v <- Maybe Version
mv, Just TreeKey
tk <- Maybe TreeKey
mtk = do
      let pm :: PackageMetadata
pm = PackageIdentifier -> TreeKey -> PackageMetadata
PackageMetadata (PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
n Version
v) TreeKey
tk
      forall (f :: * -> *) a. Applicative f => a -> f a
pure CompletePackageLocation
        { cplComplete :: PackageLocationImmutable
cplComplete = Repo -> PackageMetadata -> PackageLocationImmutable
PLIRepo Repo
repo PackageMetadata
pm
        -- This next bit is a hack: we don't know for certain that this is the case.

        -- However, for the use case where complete package metadata has been supplied,

        -- we'll assume there's a cabal file for purposes of generating a deprecation warning.

        , cplHasCabalFile :: Bool
cplHasCabalFile = Bool
True
        }
  | Bool
otherwise = do
      Package
package <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env Package
loadPackageRaw RawPackageLocationImmutable
plOrig
      let pm :: PackageMetadata
pm = Package -> PackageMetadata
packagePM Package
package
      let isSame :: a -> Maybe a -> Bool
isSame a
x (Just a
y) = a
x forall a. Eq a => a -> a -> Bool
== a
y
          isSame a
_ Maybe a
_ = Bool
True

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

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

-- | Add in hashes to make a 'SnapshotLocation' reproducible.

--

-- @since 0.1.0.0

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

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

  -> f a -- ^ input values

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

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

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

  -> f a -- ^ input values

  -> m ()
traverseConcurrentlyWith_ :: forall (m :: * -> *) (f :: * -> *) a.
(MonadUnliftIO m, Foldable f) =>
Int -> (a -> m ()) -> f a -> m ()
traverseConcurrentlyWith_ Int
count a -> m ()
f f a
t0 = do
  TVar [a]
queue <- forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f a
t0

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

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

--

-- @since 0.1.0.0

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

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

--

-- @since 0.1.0.0

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

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

--

-- @since 0.1.0.0

data CompletedPLI = CompletedPLI !RawPackageLocationImmutable !PackageLocationImmutable

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

--

-- @since 0.1.0.0

data CompletedSL = CompletedSL !RawSnapshotLocation !SnapshotLocation

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

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

-- layer.

--

-- @since 0.1.0.0

loadAndCompleteSnapshot
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => SnapshotLocation
  -> Map RawSnapshotLocation SnapshotLocation -- ^ Cached snapshot locations from lock file

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

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

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

-- the raw snapshot layer.

--

-- @since 0.5.7

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

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

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

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

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

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

-- layer.

--

-- @since 0.1.0.0

loadAndCompleteSnapshotRaw
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => RawSnapshotLocation
  -> Map RawSnapshotLocation SnapshotLocation -- ^ Cached snapshot locations from lock file

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

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

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

-- of the raw snapshot layer.

--

-- @since 0.5.7

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

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

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

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

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

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

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

--

-- @since 0.1.0.0

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

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

-- packages.

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

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

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

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

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

-- | Add more packages to a snapshot

--

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

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

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

-- set.

--

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

--

-- @since 0.1.0.0

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

  -- messages only

  -> [RawPackageLocationImmutable] -- ^ new packages

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

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

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

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

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

-- | Add more packages to a snapshot completing their locations if needed

--

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

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

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

-- set.

--

-- Returns any of the 'AddPackagesConfig' values not used and also all

-- non-trivial package location completions.

--

-- @since 0.1.0.0

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

  -- messages only

  -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached data from snapshot lock file

  -> [RawPackageLocationImmutable] -- ^ new packages

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

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

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

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

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

--

-- Returns a 'Left' value if provided an 'SLCompiler'

-- constructor. Otherwise, returns a 'Right' value providing both the

-- 'Snapshot' and a hash of the input configuration file.

--

-- @since 0.1.0.0

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

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

--

-- Returns a 'Left' value if provided an 'SLCompiler'

-- constructor. Otherwise, returns a 'Right' value providing both the

-- 'Snapshot' and a hash of the input configuration file.

--

-- @since 0.1.0.0

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

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

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

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

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

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

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

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

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

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

--

-- @since 0.1.0.0

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

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

--

-- @since 0.1.0.0

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

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

--

-- @since 0.1.0.0

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

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

--

-- @since 0.1.0.0

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

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

--

-- @since 0.1.0.0

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

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

--

-- @since 0.1.0.0

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

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

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

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

-- easily than using 'withPantryConfig' directly. Uses basically sane

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

--

-- You can use 'runPantryApp' to use this.

--

-- @since 0.1.0.0

data PantryApp = PantryApp
  { PantryApp -> SimpleApp
paSimpleApp :: !SimpleApp
  , PantryApp -> PantryConfig
paPantryConfig :: !PantryConfig
  , PantryApp -> Bool
paUseColor :: !Bool
  , PantryApp -> Int
paTermWidth :: !Int
  , PantryApp -> StylesUpdate
paStylesUpdate :: !StylesUpdate
  }

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

-- | Lens to view or modify the 'HpackExecutable' of a 'PantryConfig'

--

-- @since 0.1.0.0

hpackExecutableL :: Lens' PantryConfig HpackExecutable
hpackExecutableL :: Lens' PantryConfig HpackExecutable
hpackExecutableL HpackExecutable -> f HpackExecutable
k PantryConfig
pconfig = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\HpackExecutable
hpExe -> PantryConfig
pconfig { pcHpackExecutable :: HpackExecutable
pcHpackExecutable = HpackExecutable
hpExe }) (HpackExecutable -> f HpackExecutable
k (PantryConfig -> HpackExecutable
pcHpackExecutable PantryConfig
pconfig))

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

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

--

-- For testing, see 'runPantryAppClean'.

--

-- @since 0.1.0.0

runPantryApp :: MonadIO m => RIO PantryApp a -> m a
runPantryApp :: forall (m :: * -> *) a. MonadIO m => RIO PantryApp a -> m a
runPantryApp = forall (m :: * -> *) a.
MonadIO m =>
Int -> CasaRepoPrefix -> Int -> RIO PantryApp a -> m a
runPantryAppWith Int
8 CasaRepoPrefix
defaultCasaRepoPrefix Int
defaultCasaMaxPerRequest

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

--

-- For testing, see 'runPantryAppClean'.

--

-- @since 0.1.1.1

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

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

-- of sharing with Stack. Useful for testing.

--

-- @since 0.1.0.0

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

-- | Load the global hints from GitHub.

--

-- @since 0.1.0.0

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

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

-- | Partition a map of global packages with its versions into a Set of

-- replaced packages and its dependencies and a map of remaining (untouched) packages.

--

-- @since 0.1.0.0

partitionReplacedDependencies ::
       Ord id
    => Map PackageName a -- ^ global packages

    -> (a -> PackageName) -- ^ package name getter

    -> (a -> id) -- ^ returns unique package id used for dependency pruning

    -> (a -> [id]) -- ^ returns unique package ids of direct package dependencies

    -> Set PackageName -- ^ overrides which global dependencies should get pruned

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

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

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

-- packages in a given snapshot. This is mostly intended for usage by

-- Stack.

--

-- @since 0.1.0.0

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

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

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