    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE TupleSections #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    -- | Logic for loading up trees from HTTPS archives.
    module Pantry.Archive
      ( getArchivePackage
      , getArchive
      , getArchiveKey
      , fetchArchivesRaw
      , fetchArchives
      , findCabalOrHpackFile
      ) where

    import RIO
    import qualified Pantry.SHA256 as SHA256
    import Pantry.Storage hiding (Tree, TreeEntry)
    import Pantry.Tree
    import Pantry.Types
    import RIO.Process
    import Pantry.Internal (normalizeParents, makeTarRelative)
    import qualified RIO.Text as T
    import qualified RIO.Text.Partial as T
    import qualified RIO.List as List
    import qualified RIO.ByteString.Lazy as BL
    import qualified RIO.Map as Map
    import qualified RIO.Set as Set
    import qualified Hpack.Config as Hpack
    import Pantry.HPack (hpackVersion)
    import Data.Bits ((.&.), shiftR)
    import Path (toFilePath)
    import qualified Codec.Archive.Zip as Zip
    import qualified Data.Digest.CRC32 as CRC32
    import Distribution.PackageDescription (packageDescription, package)

    import Conduit
    import Data.Conduit.Zlib (ungzip)
    import qualified Data.Conduit.Tar as Tar
    import Pantry.HTTP

    fetchArchivesRaw
      :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
      => [(RawArchive, RawPackageMetadata)]
      -> RIO env ()
    fetchArchivesRaw :: [(RawArchive, RawPackageMetadata)] -> RIO env ()
    fetchArchivesRaw pairs :: [(RawArchive, RawPackageMetadata)]
    pairs =
      [(RawArchive, RawPackageMetadata)]
    -> ((RawArchive, RawPackageMetadata)
        -> RIO env (SHA256, FileSize, Package))
    -> RIO env ()
    forall (t :: * -> *) (f :: * -> *) a b.
    (Foldable t, Applicative f) =>
    t a -> (a -> f b) -> f ()
    for_ [(RawArchive, RawPackageMetadata)]
    pairs (((RawArchive, RawPackageMetadata)
      -> RIO env (SHA256, FileSize, Package))
     -> RIO env ())
    -> ((RawArchive, RawPackageMetadata)
        -> RIO env (SHA256, FileSize, Package))
    -> RIO env ()
    forall a b. (a -> b) -> a -> b
    $ \(ra :: RawArchive
    ra, rpm :: RawPackageMetadata
    rpm) ->
        RawPackageLocationImmutable
    -> RawArchive
    -> RawPackageMetadata
    -> RIO env (SHA256, FileSize, Package)
    forall env.
    (HasPantryConfig env, HasLogFunc env, HasProcessContext env,
     HasCallStack) =>
    RawPackageLocationImmutable
    -> RawArchive
    -> RawPackageMetadata
    -> RIO env (SHA256, FileSize, Package)
    getArchive (RawArchive -> RawPackageMetadata -> RawPackageLocationImmutable
    RPLIArchive RawArchive
    ra RawPackageMetadata
    rpm) RawArchive
    ra RawPackageMetadata
    rpm

    fetchArchives
      :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
      => [(Archive, PackageMetadata)]
      -> RIO env ()
    fetchArchives :: [(Archive, PackageMetadata)] -> RIO env ()
    fetchArchives pairs :: [(Archive, PackageMetadata)]
    pairs =
      -- TODO be more efficient, group together shared archives
      [(RawArchive, RawPackageMetadata)] -> RIO env ()
    forall env.
    (HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
    [(RawArchive, RawPackageMetadata)] -> RIO env ()
    fetchArchivesRaw [(Archive -> RawArchive
    toRawArchive Archive
    a, PackageMetadata -> RawPackageMetadata
    toRawPM PackageMetadata
    pm) | (a :: Archive
    a, pm :: PackageMetadata
    pm) <- [(Archive, PackageMetadata)]
    pairs]

    getArchiveKey
      :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
      => RawPackageLocationImmutable -- ^ for exceptions
      -> RawArchive
      -> RawPackageMetadata
      -> RIO env TreeKey
    getArchiveKey :: RawPackageLocationImmutable
    -> RawArchive -> RawPackageMetadata -> RIO env TreeKey
    getArchiveKey rpli :: RawPackageLocationImmutable
    rpli archive :: RawArchive
    archive rpm :: RawPackageMetadata
    rpm =
      Package -> TreeKey
    packageTreeKey (Package -> TreeKey) -> RIO env Package -> RIO env TreeKey
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> RawPackageLocationImmutable
    -> RawArchive -> RawPackageMetadata -> RIO env Package
    forall env.
    (HasPantryConfig env, HasLogFunc env, HasProcessContext env,
     HasCallStack) =>
    RawPackageLocationImmutable
    -> RawArchive -> RawPackageMetadata -> RIO env Package
    getArchivePackage RawPackageLocationImmutable
    rpli RawArchive
    archive RawPackageMetadata
    rpm -- potential optimization

    thd3 :: (a, b, c) -> c
    thd3 :: (a, b, c) -> c
    thd3 (_, _, z :: c
    z) = c
    z

    getArchivePackage
      :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env, HasCallStack)
      => RawPackageLocationImmutable -- ^ for exceptions
      -> RawArchive
      -> RawPackageMetadata
      -> RIO env Package
    getArchivePackage :: RawPackageLocationImmutable
    -> RawArchive -> RawPackageMetadata -> RIO env Package
    getArchivePackage rpli :: RawPackageLocationImmutable
    rpli archive :: RawArchive
    archive rpm :: RawPackageMetadata
    rpm = (SHA256, FileSize, Package) -> Package
    forall a b c. (a, b, c) -> c
    thd3 ((SHA256, FileSize, Package) -> Package)
    -> RIO env (SHA256, FileSize, Package) -> RIO env Package
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> RawPackageLocationImmutable
    -> RawArchive
    -> RawPackageMetadata
    -> RIO env (SHA256, FileSize, Package)
    forall env.
    (HasPantryConfig env, HasLogFunc env, HasProcessContext env,
     HasCallStack) =>
    RawPackageLocationImmutable
    -> RawArchive
    -> RawPackageMetadata
    -> RIO env (SHA256, FileSize, Package)
    getArchive RawPackageLocationImmutable
    rpli RawArchive
    archive RawPackageMetadata
    rpm

    getArchive
      :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env, HasCallStack)
      => RawPackageLocationImmutable -- ^ for exceptions
      -> RawArchive
      -> RawPackageMetadata
      -> RIO env (SHA256, FileSize, Package)
    getArchive :: RawPackageLocationImmutable
    -> RawArchive
    -> RawPackageMetadata
    -> RIO env (SHA256, FileSize, Package)
    getArchive rpli :: RawPackageLocationImmutable
    rpli archive :: RawArchive
    archive rpm :: RawPackageMetadata
    rpm = do
      -- Check if the value is in the archive, and use it if possible
      Maybe (SHA256, FileSize, Package)
    mcached <- RawPackageLocationImmutable
    -> RawArchive -> RIO env (Maybe (SHA256, FileSize, Package))
    forall env.
    (HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
    RawPackageLocationImmutable
    -> RawArchive -> RIO env (Maybe (SHA256, FileSize, Package))
    loadCache RawPackageLocationImmutable
    rpli RawArchive
    archive
      cached :: (SHA256, FileSize, Package)
    cached@(_, _, pa :: Package
    pa) <-
        case Maybe (SHA256, FileSize, Package)
    mcached of
          Just stored :: (SHA256, FileSize, Package)
    stored -> (SHA256, FileSize, Package) -> RIO env (SHA256, FileSize, Package)
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (SHA256, FileSize, Package)
    stored
          -- Not in the archive. Load the archive. Completely ignore the
          -- PackageMetadata for now, we'll check that the Package
          -- info matches next.
          Nothing -> RawArchive
    -> (FilePath
        -> SHA256 -> FileSize -> RIO env (SHA256, FileSize, Package))
    -> RIO env (SHA256, FileSize, Package)
    forall env a.
    HasLogFunc env =>
    RawArchive
    -> (FilePath -> SHA256 -> FileSize -> RIO env a) -> RIO env a
    withArchiveLoc RawArchive
    archive ((FilePath
      -> SHA256 -> FileSize -> RIO env (SHA256, FileSize, Package))
     -> RIO env (SHA256, FileSize, Package))
    -> (FilePath
        -> SHA256 -> FileSize -> RIO env (SHA256, FileSize, Package))
    -> RIO env (SHA256, FileSize, Package)
    forall a b. (a -> b) -> a -> b
    $ \fp :: FilePath
    fp sha :: SHA256
    sha size :: FileSize
    size -> do
            Package
    pa <- RawPackageLocationImmutable
    -> RawArchive -> FilePath -> RIO env Package
    forall env.
    (HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
    RawPackageLocationImmutable
    -> RawArchive -> FilePath -> RIO env Package
    parseArchive RawPackageLocationImmutable
    rpli RawArchive
    archive FilePath
    fp
            -- Storing in the cache exclusively uses information we have
            -- about the archive itself, not metadata from the user.
            RawArchive -> SHA256 -> FileSize -> Package -> RIO env ()
    forall env.
    (HasPantryConfig env, HasLogFunc env) =>
    RawArchive -> SHA256 -> FileSize -> Package -> RIO env ()
    storeCache RawArchive
    archive SHA256
    sha FileSize
    size Package
    pa
            (SHA256, FileSize, Package) -> RIO env (SHA256, FileSize, Package)
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (SHA256
    sha, FileSize
    size, Package
    pa)

      (PantryException -> RIO env (SHA256, FileSize, Package))
    -> (Package -> RIO env (SHA256, FileSize, Package))
    -> Either PantryException Package
    -> RIO env (SHA256, FileSize, Package)
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either PantryException -> RIO env (SHA256, FileSize, Package)
    forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
    throwIO (\_ -> (SHA256, FileSize, Package) -> RIO env (SHA256, FileSize, Package)
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (SHA256, FileSize, Package)
    cached) (Either PantryException Package
     -> RIO env (SHA256, FileSize, Package))
    -> Either PantryException Package
    -> RIO env (SHA256, FileSize, Package)
    forall a b. (a -> b) -> a -> b
    $ RawPackageLocationImmutable
    -> RawPackageMetadata -> Package -> Either PantryException Package
    checkPackageMetadata RawPackageLocationImmutable
    rpli RawPackageMetadata
    rpm Package
    pa

    storeCache
      :: forall env. (HasPantryConfig env, HasLogFunc env)
      => RawArchive
      -> SHA256
      -> FileSize
      -> Package
      -> RIO env ()
    storeCache :: RawArchive -> SHA256 -> FileSize -> Package -> RIO env ()
    storeCache archive :: RawArchive
    archive sha :: SHA256
    sha size :: FileSize
    size pa :: Package
    pa =
      case RawArchive -> ArchiveLocation
    raLocation RawArchive
    archive of
        ALUrl url :: Text
    url -> ReaderT SqlBackend (RIO env) () -> RIO env ()
    forall env a.
    (HasPantryConfig env, HasLogFunc env) =>
    ReaderT SqlBackend (RIO env) a -> RIO env a
    withStorage (ReaderT SqlBackend (RIO env) () -> RIO env ())
    -> ReaderT SqlBackend (RIO env) () -> RIO env ()
    forall a b. (a -> b) -> a -> b
    $ Text
    -> Text
    -> SHA256
    -> FileSize
    -> TreeKey
    -> ReaderT SqlBackend (RIO env) ()
    forall env.
    Text
    -> Text
    -> SHA256
    -> FileSize
    -> TreeKey
    -> ReaderT SqlBackend (RIO env) ()
    storeArchiveCache Text
    url (RawArchive -> Text
    raSubdir RawArchive
    archive) SHA256
    sha FileSize
    size (Package -> TreeKey
    packageTreeKey Package
    pa)
        ALFilePath _ -> () -> RIO env ()
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure () -- TODO cache local as well

    loadCache
      :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
      => RawPackageLocationImmutable
      -> RawArchive
      -> RIO env (Maybe (SHA256, FileSize, Package))
    loadCache :: RawPackageLocationImmutable
    -> RawArchive -> RIO env (Maybe (SHA256, FileSize, Package))
    loadCache rpli :: RawPackageLocationImmutable
    rpli archive :: RawArchive
    archive =
      case ArchiveLocation
    loc of
        ALFilePath _ -> Maybe (SHA256, FileSize, Package)
    -> RIO env (Maybe (SHA256, FileSize, Package))
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Maybe (SHA256, FileSize, Package)
    forall a. Maybe a
    Nothing -- TODO can we do something intelligent here?
        ALUrl url :: Text
    url -> ReaderT SqlBackend (RIO env) [(SHA256, FileSize, TreeId)]
    -> RIO env [(SHA256, FileSize, TreeId)]
    forall env a.
    (HasPantryConfig env, HasLogFunc env) =>
    ReaderT SqlBackend (RIO env) a -> RIO env a
    withStorage (Text
    -> Text
    -> ReaderT SqlBackend (RIO env) [(SHA256, FileSize, TreeId)]
    forall env.
    Text
    -> Text
    -> ReaderT SqlBackend (RIO env) [(SHA256, FileSize, TreeId)]
    loadArchiveCache Text
    url (RawArchive -> Text
    raSubdir RawArchive
    archive)) RIO env [(SHA256, FileSize, TreeId)]
    -> ([(SHA256, FileSize, TreeId)]
        -> RIO env (Maybe (SHA256, FileSize, Package)))
    -> RIO env (Maybe (SHA256, FileSize, Package))
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= [(SHA256, FileSize, TreeId)]
    -> RIO env (Maybe (SHA256, FileSize, Package))
    loop
      where
        loc :: ArchiveLocation
    loc = RawArchive -> ArchiveLocation
    raLocation RawArchive
    archive
        msha :: Maybe SHA256
    msha = RawArchive -> Maybe SHA256
    raHash RawArchive
    archive
        msize :: Maybe FileSize
    msize = RawArchive -> Maybe FileSize
    raSize RawArchive
    archive

        loadFromCache :: TreeId -> RIO env (Maybe Package)
        loadFromCache :: TreeId -> RIO env (Maybe Package)
    loadFromCache tid :: TreeId
    tid = (Package -> Maybe Package)
    -> RIO env Package -> RIO env (Maybe Package)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Package -> Maybe Package
    forall a. a -> Maybe a
    Just (RIO env Package -> RIO env (Maybe Package))
    -> RIO env Package -> RIO env (Maybe Package)
    forall a b. (a -> b) -> a -> b
    $ ReaderT SqlBackend (RIO env) Package -> RIO env Package
    forall env a.
    (HasPantryConfig env, HasLogFunc env) =>
    ReaderT SqlBackend (RIO env) a -> RIO env a
    withStorage (ReaderT SqlBackend (RIO env) Package -> RIO env Package)
    -> ReaderT SqlBackend (RIO env) Package -> RIO env Package
    forall a b. (a -> b) -> a -> b
    $ RawPackageLocationImmutable
    -> TreeId -> ReaderT SqlBackend (RIO env) Package
    forall env.
    (HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
    RawPackageLocationImmutable
    -> TreeId -> ReaderT SqlBackend (RIO env) Package
    loadPackageById RawPackageLocationImmutable
    rpli TreeId
    tid

        loop :: [(SHA256, FileSize, TreeId)]
    -> RIO env (Maybe (SHA256, FileSize, Package))
    loop [] = Maybe (SHA256, FileSize, Package)
    -> RIO env (Maybe (SHA256, FileSize, Package))
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Maybe (SHA256, FileSize, Package)
    forall a. Maybe a
    Nothing
        loop ((sha :: SHA256
    sha, size :: FileSize
    size, tid :: TreeId
    tid):rest :: [(SHA256, FileSize, TreeId)]
    rest) =
          case Maybe SHA256
    msha of
            Nothing -> do
              case Maybe FileSize
    msize of
                Just size' :: FileSize
    size' | FileSize
    size FileSize -> FileSize -> Bool
    forall a. Eq a => a -> a -> Bool
    /= FileSize
    size' -> [(SHA256, FileSize, TreeId)]
    -> RIO env (Maybe (SHA256, FileSize, Package))
    loop [(SHA256, FileSize, TreeId)]
    rest
                _ -> do
                  case ArchiveLocation
    loc of
                    ALUrl url :: Text
    url -> do
                      -- Only debug level, let lock files solve this
                      Utf8Builder -> RIO env ()
    forall (m :: * -> *) env.
    (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
    Utf8Builder -> m ()
    logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
    forall a b. (a -> b) -> a -> b
    $ "Using archive from " Utf8Builder -> Utf8Builder -> Utf8Builder
    forall a. Semigroup a => a -> a -> a
    <> Text -> Utf8Builder
    forall a. Display a => a -> Utf8Builder
    display Text
    url Utf8Builder -> Utf8Builder -> Utf8Builder
    forall a. Semigroup a => a -> a -> a
    <> " without a specified cryptographic hash"
                      Utf8Builder -> RIO env ()
    forall (m :: * -> *) env.
    (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
    Utf8Builder -> m ()
    logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
    forall a b. (a -> b) -> a -> b
    $ "Cached hash is " Utf8Builder -> Utf8Builder -> Utf8Builder
    forall a. Semigroup a => a -> a -> a
    <> SHA256 -> Utf8Builder
    forall a. Display a => a -> Utf8Builder
    display SHA256
    sha Utf8Builder -> Utf8Builder -> Utf8Builder
    forall a. Semigroup a => a -> a -> a
    <> ", file size " Utf8Builder -> Utf8Builder -> Utf8Builder
    forall a. Semigroup a => a -> a -> a
    <> FileSize -> Utf8Builder
    forall a. Display a => a -> Utf8Builder
    display FileSize
    size
                    ALFilePath _ -> () -> RIO env ()
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()
                  (Package -> (SHA256, FileSize, Package))
    -> Maybe Package -> Maybe (SHA256, FileSize, Package)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (SHA256
    sha, FileSize
    size,) (Maybe Package -> Maybe (SHA256, FileSize, Package))
    -> RIO env (Maybe Package)
    -> RIO env (Maybe (SHA256, FileSize, Package))
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> TreeId -> RIO env (Maybe Package)
    loadFromCache TreeId
    tid
            Just sha' :: SHA256
    sha'
              | SHA256
    sha SHA256 -> SHA256 -> Bool
    forall a. Eq a => a -> a -> Bool
    == SHA256
    sha' ->
                  case Maybe FileSize
    msize of
                    Nothing -> do
                      case ArchiveLocation
    loc of
                        -- Only debug level, let lock files solve this
                        ALUrl url :: Text
    url -> Utf8Builder -> RIO env ()
    forall (m :: * -> *) env.
    (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
    Utf8Builder -> m ()
    logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
    forall a b. (a -> b) -> a -> b
    $ "Archive from " Utf8Builder -> Utf8Builder -> Utf8Builder
    forall a. Semigroup a => a -> a -> a
    <> Text -> Utf8Builder
    forall a. Display a => a -> Utf8Builder
    display Text
    url Utf8Builder -> Utf8Builder -> Utf8Builder
    forall a. Semigroup a => a -> a -> a
    <> " does not specify a size"
                        ALFilePath _ -> () -> RIO env ()
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()
                      (Package -> (SHA256, FileSize, Package))
    -> Maybe Package -> Maybe (SHA256, FileSize, Package)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (SHA256
    sha, FileSize
    size,) (Maybe Package -> Maybe (SHA256, FileSize, Package))
    -> RIO env (Maybe Package)
    -> RIO env (Maybe (SHA256, FileSize, Package))
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> TreeId -> RIO env (Maybe Package)
    loadFromCache TreeId
    tid
                    Just size' :: FileSize
    size'
                      | FileSize
    size FileSize -> FileSize -> Bool
    forall a. Eq a => a -> a -> Bool
    == FileSize
    size' -> (Package -> (SHA256, FileSize, Package))
    -> Maybe Package -> Maybe (SHA256, FileSize, Package)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (SHA256
    sha, FileSize
    size,) (Maybe Package -> Maybe (SHA256, FileSize, Package))
    -> RIO env (Maybe Package)
    -> RIO env (Maybe (SHA256, FileSize, Package))
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> TreeId -> RIO env (Maybe Package)
    loadFromCache TreeId
    tid
                      | Bool
    otherwise -> do
                          -- This is an actual warning, since we have a concrete mismatch
                          Utf8Builder -> RIO env ()
    forall (m :: * -> *) env.
    (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
    Utf8Builder -> m ()
    logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
    forall a b. (a -> b) -> a -> b
    $ "Archive from " Utf8Builder -> Utf8Builder -> Utf8Builder
    forall a. Semigroup a => a -> a -> a
    <> ArchiveLocation -> Utf8Builder
    forall a. Display a => a -> Utf8Builder
    display ArchiveLocation
    loc Utf8Builder -> Utf8Builder -> Utf8Builder
    forall a. Semigroup a => a -> a -> a
    <> " has a matching hash but mismatched size"
                          Utf8Builder -> RIO env ()
    forall (m :: * -> *) env.
    (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
    Utf8Builder -> m ()
    logWarn "Please verify that your configuration provides the correct size"
                          [(SHA256, FileSize, TreeId)]
    -> RIO env (Maybe (SHA256, FileSize, Package))
    loop [(SHA256, FileSize, TreeId)]
    rest
              | Bool
    otherwise -> [(SHA256, FileSize, TreeId)]
    -> RIO env (Maybe (SHA256, FileSize, Package))
    loop [(SHA256, FileSize, TreeId)]
    rest

    -- ensure name, version, etc are correct
    checkPackageMetadata
      :: RawPackageLocationImmutable
      -> RawPackageMetadata
      -> Package
      -> Either PantryException Package
    checkPackageMetadata :: RawPackageLocationImmutable
    -> RawPackageMetadata -> Package -> Either PantryException Package
    checkPackageMetadata pl :: RawPackageLocationImmutable
    pl pm :: RawPackageMetadata
    pm pa :: Package
    pa = do
      let
          err :: PantryException
    err = RawPackageLocationImmutable
    -> RawPackageMetadata
    -> Maybe TreeKey
    -> PackageIdentifier
    -> PantryException
    MismatchedPackageMetadata
                  RawPackageLocationImmutable
    pl
                  RawPackageMetadata
    pm
                  (TreeKey -> Maybe TreeKey
    forall a. a -> Maybe a
    Just (Package -> TreeKey
    packageTreeKey Package
    pa))
                  (Package -> PackageIdentifier
    packageIdent Package
    pa)

          test :: Eq a => Maybe a -> a -> Bool
          test :: Maybe a -> a -> Bool
    test (Just x :: a
    x) y :: a
    y = a
    x a -> a -> Bool
    forall a. Eq a => a -> a -> Bool
    == a
    y
          test Nothing _ = Bool
    True

          tests :: [Bool]
    tests =
            [ Maybe TreeKey -> TreeKey -> Bool
    forall a. Eq a => Maybe a -> a -> Bool
    test (RawPackageMetadata -> Maybe TreeKey
    rpmTreeKey RawPackageMetadata
    pm) (Package -> TreeKey
    packageTreeKey Package
    pa)
            , Maybe PackageName -> PackageName -> Bool
    forall a. Eq a => Maybe a -> a -> Bool
    test (RawPackageMetadata -> Maybe PackageName
    rpmName RawPackageMetadata
    pm) (PackageIdentifier -> PackageName
    pkgName (PackageIdentifier -> PackageName)
    -> PackageIdentifier -> PackageName
    forall a b. (a -> b) -> a -> b
    $ Package -> PackageIdentifier
    packageIdent Package
    pa)
            , Maybe Version -> Version -> Bool
    forall a. Eq a => Maybe a -> a -> Bool
    test (RawPackageMetadata -> Maybe Version
    rpmVersion RawPackageMetadata
    pm) (PackageIdentifier -> Version
    pkgVersion (PackageIdentifier -> Version) -> PackageIdentifier -> Version
    forall a b. (a -> b) -> a -> b
    $ Package -> PackageIdentifier
    packageIdent Package
    pa)
            ]

       in if [Bool] -> Bool
    forall (t :: * -> *). Foldable t => t Bool -> Bool
    and [Bool]
    tests then Package -> Either PantryException Package
    forall a b. b -> Either a b
    Right Package
    pa else PantryException -> Either PantryException Package
    forall a b. a -> Either a b
    Left PantryException
    err

    -- | Provide a local file with the contents of the archive, regardless
    -- of where it comes from. Perform SHA256 and file size validation if
    -- downloading.
    withArchiveLoc
      :: HasLogFunc env
      => RawArchive
      -> (FilePath -> SHA256 -> FileSize -> RIO env a)
      -> RIO env a
    withArchiveLoc :: RawArchive
    -> (FilePath -> SHA256 -> FileSize -> RIO env a) -> RIO env a
    withArchiveLoc (RawArchive (ALFilePath resolved :: ResolvedPath File
    resolved) msha :: Maybe SHA256
    msha msize :: Maybe FileSize
    msize _subdir :: Text
    _subdir) f :: FilePath -> SHA256 -> FileSize -> RIO env a
    f = do
      let abs' :: Path Abs File
    abs' = ResolvedPath File -> Path Abs File
    forall t. ResolvedPath t -> Path Abs t
    resolvedAbsolute ResolvedPath File
    resolved
          fp :: FilePath
    fp = Path Abs File -> FilePath
    forall b t. Path b t -> FilePath
    toFilePath Path Abs File
    abs'
      (sha :: SHA256
    sha, size :: FileSize
    size) <- FilePath
    -> IOMode
    -> (Handle -> RIO env (SHA256, FileSize))
    -> RIO env (SHA256, FileSize)
    forall (m :: * -> *) a.
    MonadUnliftIO m =>
    FilePath -> IOMode -> (Handle -> m a) -> m a
    withBinaryFile FilePath
    fp IOMode
    ReadMode ((Handle -> RIO env (SHA256, FileSize))
     -> RIO env (SHA256, FileSize))
    -> (Handle -> RIO env (SHA256, FileSize))
    -> RIO env (SHA256, FileSize)
    forall a b. (a -> b) -> a -> b
    $ \h :: Handle
    h -> do
        FileSize
    size <- Word -> FileSize
    FileSize (Word -> FileSize) -> (Integer -> Word) -> Integer -> FileSize
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Integer -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Integer -> FileSize) -> RIO env Integer -> RIO env FileSize
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Handle -> RIO env Integer
    forall (m :: * -> *). MonadIO m => Handle -> m Integer
    hFileSize Handle
    h
        Maybe FileSize -> (FileSize -> RIO env ()) -> RIO env ()
    forall (t :: * -> *) (f :: * -> *) a b.
    (Foldable t, Applicative f) =>
    t a -> (a -> f b) -> f ()
    for_ Maybe FileSize
    msize ((FileSize -> RIO env ()) -> RIO env ())
    -> (FileSize -> RIO env ()) -> RIO env ()
    forall a b. (a -> b) -> a -> b
    $ \size' :: FileSize
    size' -> Bool -> RIO env () -> RIO env ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (FileSize
    size FileSize -> FileSize -> Bool
    forall a. Eq a => a -> a -> Bool
    /= FileSize
    size') (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
    forall a b. (a -> b) -> a -> b
    $ PantryException -> RIO env ()
    forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
    throwIO (PantryException -> RIO env ()) -> PantryException -> RIO env ()
    forall a b. (a -> b) -> a -> b
    $ Path Abs File -> Mismatch FileSize -> PantryException
    LocalInvalidSize Path Abs File
    abs' $WMismatch :: forall a. a -> a -> Mismatch a
    Mismatch
          { mismatchExpected :: FileSize
    mismatchExpected = FileSize
    size'
          , mismatchActual :: FileSize
    mismatchActual = FileSize
    size
          }

        SHA256
    sha <- ConduitT () Void (RIO env) SHA256 -> RIO env SHA256
    forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
    runConduit (Handle -> ConduitT () ByteString (RIO env) ()
    forall (m :: * -> *) i.
    MonadIO m =>
    Handle -> ConduitT i ByteString m ()
    sourceHandle Handle
    h ConduitT () ByteString (RIO env) ()
    -> ConduitM ByteString Void (RIO env) SHA256
    -> ConduitT () Void (RIO env) SHA256
    forall (m :: * -> *) a b c r.
    Monad m =>
    ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
    .| ConduitM ByteString Void (RIO env) SHA256
    forall (m :: * -> *) o. Monad m => ConduitT ByteString o m SHA256
    SHA256.sinkHash)
        Maybe SHA256 -> (SHA256 -> RIO env ()) -> RIO env ()
    forall (t :: * -> *) (f :: * -> *) a b.
    (Foldable t, Applicative f) =>
    t a -> (a -> f b) -> f ()
    for_ Maybe SHA256
    msha ((SHA256 -> RIO env ()) -> RIO env ())
    -> (SHA256 -> RIO env ()) -> RIO env ()
    forall a b. (a -> b) -> a -> b
    $ \sha' :: SHA256
    sha' -> Bool -> RIO env () -> RIO env ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (SHA256
    sha SHA256 -> SHA256 -> Bool
    forall a. Eq a => a -> a -> Bool
    /= SHA256
    sha') (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
    forall a b. (a -> b) -> a -> b
    $ PantryException -> RIO env ()
    forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
    throwIO (PantryException -> RIO env ()) -> PantryException -> RIO env ()
    forall a b. (a -> b) -> a -> b
    $ Path Abs File -> Mismatch SHA256 -> PantryException
    LocalInvalidSHA256 Path Abs File
    abs' $WMismatch :: forall a. a -> a -> Mismatch a
    Mismatch
          { mismatchExpected :: SHA256
    mismatchExpected = SHA256
    sha'
          , mismatchActual :: SHA256
    mismatchActual = SHA256
    sha
          }

        (SHA256, FileSize) -> RIO env (SHA256, FileSize)
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (SHA256
    sha, FileSize
    size)
      FilePath -> SHA256 -> FileSize -> RIO env a
    f FilePath
    fp SHA256
    sha FileSize
    size
    withArchiveLoc (RawArchive (ALUrl url :: Text
    url) msha :: Maybe SHA256
    msha msize :: Maybe FileSize
    msize _subdir :: Text
    _subdir) f :: FilePath -> SHA256 -> FileSize -> RIO env a
    f =
      FilePath -> (FilePath -> Handle -> RIO env a) -> RIO env a
    forall (m :: * -> *) a.
    MonadUnliftIO m =>
    FilePath -> (FilePath -> Handle -> m a) -> m a
    withSystemTempFile "archive" ((FilePath -> Handle -> RIO env a) -> RIO env a)
    -> (FilePath -> Handle -> RIO env a) -> RIO env a
    forall a b. (a -> b) -> a -> b
    $ \fp :: FilePath
    fp hout :: Handle
    hout -> do
        Utf8Builder -> RIO env ()
    forall (m :: * -> *) env.
    (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
    Utf8Builder -> m ()
    logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
    forall a b. (a -> b) -> a -> b
    $ "Downloading archive from " Utf8Builder -> Utf8Builder -> Utf8Builder
    forall a. Semigroup a => a -> a -> a
    <> Text -> Utf8Builder
    forall a. Display a => a -> Utf8Builder
    display Text
    url
        (sha :: SHA256
    sha, size :: FileSize
    size, ()) <- Text
    -> Maybe SHA256
    -> Maybe FileSize
    -> ConduitT ByteString Void (RIO env) ()
    -> RIO env (SHA256, FileSize, ())
    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 (Handle -> ConduitT ByteString Void (RIO env) ()
    forall (m :: * -> *) o.
    MonadIO m =>
    Handle -> ConduitT ByteString o m ()
    sinkHandle Handle
    hout)
        Handle -> RIO env ()
    forall (m :: * -> *). MonadIO m => Handle -> m ()
    hClose Handle
    hout
        FilePath -> SHA256 -> FileSize -> RIO env a
    f FilePath
    fp SHA256
    sha FileSize
    size

    data ArchiveType = ATTarGz | ATTar | ATZip
      deriving (Int -> ArchiveType
    ArchiveType -> Int
    ArchiveType -> [ArchiveType]
    ArchiveType -> ArchiveType
    ArchiveType -> ArchiveType -> [ArchiveType]
    ArchiveType -> ArchiveType -> ArchiveType -> [ArchiveType]
    (ArchiveType -> ArchiveType)
    -> (ArchiveType -> ArchiveType)
    -> (Int -> ArchiveType)
    -> (ArchiveType -> Int)
    -> (ArchiveType -> [ArchiveType])
    -> (ArchiveType -> ArchiveType -> [ArchiveType])
    -> (ArchiveType -> ArchiveType -> [ArchiveType])
    -> (ArchiveType -> ArchiveType -> ArchiveType -> [ArchiveType])
    -> Enum ArchiveType
    forall a.
    (a -> a)
    -> (a -> a)
    -> (Int -> a)
    -> (a -> Int)
    -> (a -> [a])
    -> (a -> a -> [a])
    -> (a -> a -> [a])
    -> (a -> a -> a -> [a])
    -> Enum a
    enumFromThenTo :: ArchiveType -> ArchiveType -> ArchiveType -> [ArchiveType]
    $cenumFromThenTo :: ArchiveType -> ArchiveType -> ArchiveType -> [ArchiveType]
    enumFromTo :: ArchiveType -> ArchiveType -> [ArchiveType]
    $cenumFromTo :: ArchiveType -> ArchiveType -> [ArchiveType]
    enumFromThen :: ArchiveType -> ArchiveType -> [ArchiveType]
    $cenumFromThen :: ArchiveType -> ArchiveType -> [ArchiveType]
    enumFrom :: ArchiveType -> [ArchiveType]
    $cenumFrom :: ArchiveType -> [ArchiveType]
    fromEnum :: ArchiveType -> Int
    $cfromEnum :: ArchiveType -> Int
    toEnum :: Int -> ArchiveType
    $ctoEnum :: Int -> ArchiveType
    pred :: ArchiveType -> ArchiveType
    $cpred :: ArchiveType -> ArchiveType
    succ :: ArchiveType -> ArchiveType
    $csucc :: ArchiveType -> ArchiveType
    Enum, ArchiveType
    ArchiveType -> ArchiveType -> Bounded ArchiveType
    forall a. a -> a -> Bounded a
    maxBound :: ArchiveType
    $cmaxBound :: ArchiveType
    minBound :: ArchiveType
    $cminBound :: ArchiveType
    Bounded)

    instance Display ArchiveType where
      display :: ArchiveType -> Utf8Builder
    display ATTarGz = "GZIP-ed tar file"
      display ATTar = "Uncompressed tar file"
      display ATZip = "Zip file"

    data METype
      = METNormal
      | METExecutable
      | METLink !FilePath
      deriving Int -> METype -> ShowS
    [METype] -> ShowS
    METype -> FilePath
    (Int -> METype -> ShowS)
    -> (METype -> FilePath) -> ([METype] -> ShowS) -> Show METype
    forall a.
    (Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
    showList :: [METype] -> ShowS
    $cshowList :: [METype] -> ShowS
    show :: METype -> FilePath
    $cshow :: METype -> FilePath
    showsPrec :: Int -> METype -> ShowS
    $cshowsPrec :: Int -> METype -> ShowS
    Show

    data MetaEntry = MetaEntry
      { MetaEntry -> FilePath
    mePath :: !FilePath
      , MetaEntry -> METype
    meType :: !METype
      }
      deriving Int -> MetaEntry -> ShowS
    [MetaEntry] -> ShowS
    MetaEntry -> FilePath
    (Int -> MetaEntry -> ShowS)
    -> (MetaEntry -> FilePath)
    -> ([MetaEntry] -> ShowS)
    -> Show MetaEntry
    forall a.
    (Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
    showList :: [MetaEntry] -> ShowS
    $cshowList :: [MetaEntry] -> ShowS
    show :: MetaEntry -> FilePath
    $cshow :: MetaEntry -> FilePath
    showsPrec :: Int -> MetaEntry -> ShowS
    $cshowsPrec :: Int -> MetaEntry -> ShowS
    Show

    foldArchive
      :: (HasPantryConfig env, HasLogFunc env)
      => ArchiveLocation -- ^ for error reporting
      -> FilePath
      -> ArchiveType
      -> a
      -> (a -> MetaEntry -> ConduitT ByteString Void (RIO env) a)
      -> RIO env a
    foldArchive :: ArchiveLocation
    -> FilePath
    -> ArchiveType
    -> a
    -> (a -> MetaEntry -> ConduitT ByteString Void (RIO env) a)
    -> RIO env a
    foldArchive loc :: ArchiveLocation
    loc fp :: FilePath
    fp ATTarGz accum :: a
    accum f :: a -> MetaEntry -> ConduitT ByteString Void (RIO env) a
    f =
      FilePath
    -> (ConduitM () ByteString (RIO env) () -> RIO env a) -> RIO env a
    forall (m :: * -> *) (n :: * -> *) i a.
    (MonadUnliftIO m, MonadIO n) =>
    FilePath -> (ConduitM i ByteString n () -> m a) -> m a
    withSourceFile FilePath
    fp ((ConduitM () ByteString (RIO env) () -> RIO env a) -> RIO env a)
    -> (ConduitM () ByteString (RIO env) () -> RIO env a) -> RIO env a
    forall a b. (a -> b) -> a -> b
    $ \src :: ConduitM () ByteString (RIO env) ()
    src -> ConduitT () Void (RIO env) a -> RIO env a
    forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
    runConduit (ConduitT () Void (RIO env) a -> RIO env a)
    -> ConduitT () Void (RIO env) a -> RIO env a
    forall a b. (a -> b) -> a -> b
    $ ConduitM () ByteString (RIO env) ()
    src ConduitM () ByteString (RIO env) ()
    -> ConduitT ByteString Void (RIO env) a
    -> ConduitT () Void (RIO env) a
    forall (m :: * -> *) a b c r.
    Monad m =>
    ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
    .| ConduitT ByteString ByteString (RIO env) ()
    forall (m :: * -> *).
    (PrimMonad m, MonadThrow m) =>
    ConduitT ByteString ByteString m ()
    ungzip ConduitT ByteString ByteString (RIO env) ()
    -> ConduitT ByteString Void (RIO env) a
    -> ConduitT ByteString Void (RIO env) a
    forall (m :: * -> *) a b c r.
    Monad m =>
    ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
    .| ArchiveLocation
    -> a
    -> (a -> MetaEntry -> ConduitT ByteString Void (RIO env) a)
    -> ConduitT ByteString Void (RIO env) a
    forall env a o.
    (HasPantryConfig env, HasLogFunc env) =>
    ArchiveLocation
    -> a
    -> (a -> MetaEntry -> ConduitT ByteString o (RIO env) a)
    -> ConduitT ByteString o (RIO env) a
    foldTar ArchiveLocation
    loc a
    accum a -> MetaEntry -> ConduitT ByteString Void (RIO env) a
    f
    foldArchive loc :: ArchiveLocation
    loc fp :: FilePath
    fp ATTar accum :: a
    accum f :: a -> MetaEntry -> ConduitT ByteString Void (RIO env) a
    f =
      FilePath
    -> (ConduitM () ByteString (RIO env) () -> RIO env a) -> RIO env a
    forall (m :: * -> *) (n :: * -> *) i a.
    (MonadUnliftIO m, MonadIO n) =>
    FilePath -> (ConduitM i ByteString n () -> m a) -> m a
    withSourceFile FilePath
    fp ((ConduitM () ByteString (RIO env) () -> RIO env a) -> RIO env a)
    -> (ConduitM () ByteString (RIO env) () -> RIO env a) -> RIO env a
    forall a b. (a -> b) -> a -> b
    $ \src :: ConduitM () ByteString (RIO env) ()
    src -> ConduitT () Void (RIO env) a -> RIO env a
    forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
    runConduit (ConduitT () Void (RIO env) a -> RIO env a)
    -> ConduitT () Void (RIO env) a -> RIO env a
    forall a b. (a -> b) -> a -> b
    $ ConduitM () ByteString (RIO env) ()
    src ConduitM () ByteString (RIO env) ()
    -> ConduitT ByteString Void (RIO env) a
    -> ConduitT () Void (RIO env) a
    forall (m :: * -> *) a b c r.
    Monad m =>
    ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
    .| ArchiveLocation
    -> a
    -> (a -> MetaEntry -> ConduitT ByteString Void (RIO env) a)
    -> ConduitT ByteString Void (RIO env) a
    forall env a o.
    (HasPantryConfig env, HasLogFunc env) =>
    ArchiveLocation
    -> a
    -> (a -> MetaEntry -> ConduitT ByteString o (RIO env) a)
    -> ConduitT ByteString o (RIO env) a
    foldTar ArchiveLocation
    loc a
    accum a -> MetaEntry -> ConduitT ByteString Void (RIO env) a
    f
    foldArchive loc :: ArchiveLocation
    loc fp :: FilePath
    fp ATZip accum0 :: a
    accum0 f :: a -> MetaEntry -> ConduitT ByteString Void (RIO env) a
    f = FilePath -> IOMode -> (Handle -> RIO env a) -> RIO env a
    forall (m :: * -> *) a.
    MonadUnliftIO m =>
    FilePath -> IOMode -> (Handle -> m a) -> m a
    withBinaryFile FilePath
    fp IOMode
    ReadMode ((Handle -> RIO env a) -> RIO env a)
    -> (Handle -> RIO env a) -> RIO env a
    forall a b. (a -> b) -> a -> b
    $ \h :: Handle
    h -> do
      let go :: a -> Entry -> RIO env a
    go accum :: a
    accum entry :: Entry
    entry = do
            let me :: MetaEntry
    me = FilePath -> METype -> MetaEntry
    MetaEntry (Entry -> FilePath
    Zip.eRelativePath Entry
    entry) METype
    met
                met :: METype
    met = METype -> Maybe METype -> METype
    forall a. a -> Maybe a -> a
    fromMaybe METype
    METNormal (Maybe METype -> METype) -> Maybe METype -> METype
    forall a b. (a -> b) -> a -> b
    $ do
                  let modes :: Word32
    modes = Word32 -> Int -> Word32
    forall a. Bits a => a -> Int -> a
    shiftR (Entry -> Word32
    Zip.eExternalFileAttributes Entry
    entry) 16
                  Bool -> Maybe ()
    forall (f :: * -> *). Alternative f => Bool -> f ()
    guard (Bool -> Maybe ()) -> Bool -> Maybe ()
    forall a b. (a -> b) -> a -> b
    $ Entry -> Word16
    Zip.eVersionMadeBy Entry
    entry Word16 -> Word16 -> Word16
    forall a. Bits a => a -> a -> a
    .&. 0xFF00 Word16 -> Word16 -> Bool
    forall a. Eq a => a -> a -> Bool
    == 0x0300
                  Bool -> Maybe ()
    forall (f :: * -> *). Alternative f => Bool -> f ()
    guard (Bool -> Maybe ()) -> Bool -> Maybe ()
    forall a b. (a -> b) -> a -> b
    $ Word32
    modes Word32 -> Word32 -> Bool
    forall a. Eq a => a -> a -> Bool
    /= 0
                  METype -> Maybe METype
    forall a. a -> Maybe a
    Just (METype -> Maybe METype) -> METype -> Maybe METype
    forall a b. (a -> b) -> a -> b
    $
                    if (Word32
    modes Word32 -> Word32 -> Word32
    forall a. Bits a => a -> a -> a
    .&. 0o100) Word32 -> Word32 -> Bool
    forall a. Eq a => a -> a -> Bool
    == 0
                      then METype
    METNormal
                      else METype
    METExecutable
                lbs :: ByteString
    lbs = Entry -> ByteString
    Zip.fromEntry Entry
    entry
            let crcExpected :: Word32
    crcExpected = Entry -> Word32
    Zip.eCRC32 Entry
    entry
                crcActual :: Word32
    crcActual = ByteString -> Word32
    forall a. CRC32 a => a -> Word32
    CRC32.crc32 ByteString
    lbs
            Bool -> RIO env () -> RIO env ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Word32
    crcExpected Word32 -> Word32 -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Word32
    crcActual)
              (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
    forall a b. (a -> b) -> a -> b
    $ PantryException -> RIO env ()
    forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
    throwIO (PantryException -> RIO env ()) -> PantryException -> RIO env ()
    forall a b. (a -> b) -> a -> b
    $ ArchiveLocation -> FilePath -> Mismatch Word32 -> PantryException
    CRC32Mismatch ArchiveLocation
    loc (Entry -> FilePath
    Zip.eRelativePath Entry
    entry) $WMismatch :: forall a. a -> a -> Mismatch a
    Mismatch
                  { mismatchExpected :: Word32
    mismatchExpected = Word32
    crcExpected
                  , mismatchActual :: Word32
    mismatchActual = Word32
    crcActual
                  }
            ConduitT () Void (RIO env) a -> RIO env a
    forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
    runConduit (ConduitT () Void (RIO env) a -> RIO env a)
    -> ConduitT () Void (RIO env) a -> RIO env a
    forall a b. (a -> b) -> a -> b
    $ ByteString -> ConduitM () ByteString (RIO env) ()
    forall (m :: * -> *) lazy strict i.
    (Monad m, LazySequence lazy strict) =>
    lazy -> ConduitT i strict m ()
    sourceLazy ByteString
    lbs ConduitM () ByteString (RIO env) ()
    -> ConduitT ByteString Void (RIO env) a
    -> ConduitT () Void (RIO env) a
    forall (m :: * -> *) a b c r.
    Monad m =>
    ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
    .| a -> MetaEntry -> ConduitT ByteString Void (RIO env) a
    f a
    accum MetaEntry
    me
          isDir :: Entry -> Bool
    isDir entry :: Entry
    entry =
            case ShowS
    forall a. [a] -> [a]
    reverse ShowS -> ShowS
    forall a b. (a -> b) -> a -> b
    $ Entry -> FilePath
    Zip.eRelativePath Entry
    entry of
              '/':_ -> Bool
    True
              _ -> Bool
    False
      -- We're entering lazy I/O land thanks to zip-archive.
      ByteString
    lbs <- Handle -> RIO env ByteString
    forall (m :: * -> *). MonadIO m => Handle -> m ByteString
    BL.hGetContents Handle
    h
      (a -> Entry -> RIO env a) -> a -> [Entry] -> RIO env a
    forall (t :: * -> *) (m :: * -> *) b a.
    (Foldable t, Monad m) =>
    (b -> a -> m b) -> b -> t a -> m b
    foldM a -> Entry -> RIO env a
    go a
    accum0 ((Entry -> Bool) -> [Entry] -> [Entry]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Bool -> Bool
    not (Bool -> Bool) -> (Entry -> Bool) -> Entry -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Entry -> Bool
    isDir) ([Entry] -> [Entry]) -> [Entry] -> [Entry]
    forall a b. (a -> b) -> a -> b
    $ Archive -> [Entry]
    Zip.zEntries (Archive -> [Entry]) -> Archive -> [Entry]
    forall a b. (a -> b) -> a -> b
    $ ByteString -> Archive
    Zip.toArchive ByteString
    lbs)

    foldTar
      :: (HasPantryConfig env, HasLogFunc env)
      => ArchiveLocation -- ^ for exceptions
      -> a
      -> (a -> MetaEntry -> ConduitT ByteString o (RIO env) a)
      -> ConduitT ByteString o (RIO env) a
    foldTar :: ArchiveLocation
    -> a
    -> (a -> MetaEntry -> ConduitT ByteString o (RIO env) a)
    -> ConduitT ByteString o (RIO env) a
    foldTar loc :: ArchiveLocation
    loc accum0 :: a
    accum0 f :: a -> MetaEntry -> ConduitT ByteString o (RIO env) a
    f = do
      IORef a
    ref <- a -> ConduitT ByteString o (RIO env) (IORef a)
    forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
    newIORef a
    accum0
      (FileInfo -> ConduitM ByteString o (RIO env) ())
    -> ConduitM ByteString o (RIO env) ()
    forall (m :: * -> *) o.
    MonadThrow m =>
    (FileInfo -> ConduitM ByteString o m ())
    -> ConduitM ByteString o m ()
    Tar.untar ((FileInfo -> ConduitM ByteString o (RIO env) ())
     -> ConduitM ByteString o (RIO env) ())
    -> (FileInfo -> ConduitM ByteString o (RIO env) ())
    -> ConduitM ByteString o (RIO env) ()
    forall a b. (a -> b) -> a -> b
    $ \fi :: FileInfo
    fi -> FileInfo -> ConduitT ByteString o (RIO env) (Maybe MetaEntry)
    forall (m :: * -> *). MonadIO m => FileInfo -> m (Maybe MetaEntry)
    toME FileInfo
    fi ConduitT ByteString o (RIO env) (Maybe MetaEntry)
    -> (Maybe MetaEntry -> ConduitM ByteString o (RIO env) ())
    -> ConduitM ByteString o (RIO env) ()
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= (MetaEntry -> ConduitM ByteString o (RIO env) ())
    -> Maybe MetaEntry -> ConduitM ByteString o (RIO env) ()
    forall (t :: * -> *) (f :: * -> *) a b.
    (Foldable t, Applicative f) =>
    (a -> f b) -> t a -> f ()
    traverse_ (\me :: MetaEntry
    me -> do
        a
    accum <- IORef a -> ConduitT ByteString o (RIO env) a
    forall (m :: * -> *) a. MonadIO m => IORef a -> m a
    readIORef IORef a
    ref
        a
    accum' <- a -> MetaEntry -> ConduitT ByteString o (RIO env) a
    f a
    accum MetaEntry
    me
        IORef a -> a -> ConduitM ByteString o (RIO env) ()
    forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
    writeIORef IORef a
    ref (a -> ConduitM ByteString o (RIO env) ())
    -> a -> ConduitM ByteString o (RIO env) ()
    forall a b. (a -> b) -> a -> b
    $! a
    accum')
      IORef a -> ConduitT ByteString o (RIO env) a
    forall (m :: * -> *) a. MonadIO m => IORef a -> m a
    readIORef IORef a
    ref
      where
        toME :: MonadIO m => Tar.FileInfo -> m (Maybe MetaEntry)
        toME :: FileInfo -> m (Maybe MetaEntry)
    toME fi :: FileInfo
    fi = do
          let exc :: PantryException
    exc = ArchiveLocation -> FilePath -> FileType -> PantryException
    InvalidTarFileType ArchiveLocation
    loc (FileInfo -> FilePath
    Tar.getFileInfoPath FileInfo
    fi) (FileInfo -> FileType
    Tar.fileType FileInfo
    fi)
          Maybe METype
    mmet <-
            case FileInfo -> FileType
    Tar.fileType FileInfo
    fi of
              Tar.FTSymbolicLink bs :: ByteString
    bs ->
                case ByteString -> Either UnicodeException Text
    decodeUtf8' ByteString
    bs of
                  Left _ -> PantryException -> m (Maybe METype)
    forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
    throwIO PantryException
    exc
                  Right text :: Text
    text -> Maybe METype -> m (Maybe METype)
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Maybe METype -> m (Maybe METype))
    -> Maybe METype -> m (Maybe METype)
    forall a b. (a -> b) -> a -> b
    $ METype -> Maybe METype
    forall a. a -> Maybe a
    Just (METype -> Maybe METype) -> METype -> Maybe METype
    forall a b. (a -> b) -> a -> b
    $ FilePath -> METype
    METLink (FilePath -> METype) -> FilePath -> METype
    forall a b. (a -> b) -> a -> b
    $ Text -> FilePath
    T.unpack Text
    text
              Tar.FTNormal -> Maybe METype -> m (Maybe METype)
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Maybe METype -> m (Maybe METype))
    -> Maybe METype -> m (Maybe METype)
    forall a b. (a -> b) -> a -> b
    $ METype -> Maybe METype
    forall a. a -> Maybe a
    Just (METype -> Maybe METype) -> METype -> Maybe METype
    forall a b. (a -> b) -> a -> b
    $
                if FileInfo -> FileMode
    Tar.fileMode FileInfo
    fi FileMode -> FileMode -> FileMode
    forall a. Bits a => a -> a -> a
    .&. 0o100 FileMode -> FileMode -> Bool
    forall a. Eq a => a -> a -> Bool
    /= 0
                  then METype
    METExecutable
                  else METype
    METNormal
              Tar.FTDirectory -> Maybe METype -> m (Maybe METype)
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Maybe METype
    forall a. Maybe a
    Nothing
              _ -> PantryException -> m (Maybe METype)
    forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
    throwIO PantryException
    exc
          Maybe MetaEntry -> m (Maybe MetaEntry)
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Maybe MetaEntry -> m (Maybe MetaEntry))
    -> Maybe MetaEntry -> m (Maybe MetaEntry)
    forall a b. (a -> b) -> a -> b
    $
            (\met :: METype
    met -> $WMetaEntry :: FilePath -> METype -> MetaEntry
    MetaEntry
              { mePath :: FilePath
    mePath = FileInfo -> FilePath
    Tar.getFileInfoPath FileInfo
    fi
              , meType :: METype
    meType = METype
    met
              })
            (METype -> MetaEntry) -> Maybe METype -> Maybe MetaEntry
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Maybe METype
    mmet

    data SimpleEntry = SimpleEntry
      { SimpleEntry -> FilePath
    seSource :: !FilePath
      , SimpleEntry -> FileType
    seType :: !FileType
      }
      deriving Int -> SimpleEntry -> ShowS
    [SimpleEntry] -> ShowS
    SimpleEntry -> FilePath
    (Int -> SimpleEntry -> ShowS)
    -> (SimpleEntry -> FilePath)
    -> ([SimpleEntry] -> ShowS)
    -> Show SimpleEntry
    forall a.
    (Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
    showList :: [SimpleEntry] -> ShowS
    $cshowList :: [SimpleEntry] -> ShowS
    show :: SimpleEntry -> FilePath
    $cshow :: SimpleEntry -> FilePath
    showsPrec :: Int -> SimpleEntry -> ShowS
    $cshowsPrec :: Int -> SimpleEntry -> ShowS
    Show

    -- | Attempt to parse the contents of the given archive in the given
    -- subdir into a 'Tree'. This will not consult any caches. It will
    -- ensure that:
    --
    -- * The cabal file exists
    --
    -- * The cabal file can be parsed
    --
    -- * The name inside the cabal file matches the name of the cabal file itself
    parseArchive
      :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
      => RawPackageLocationImmutable
      -> RawArchive
      -> FilePath -- ^ file holding the archive
      -> RIO env Package
    parseArchive :: RawPackageLocationImmutable
    -> RawArchive -> FilePath -> RIO env Package
    parseArchive rpli :: RawPackageLocationImmutable
    rpli archive :: RawArchive
    archive fp :: FilePath
    fp = do
      let loc :: ArchiveLocation
    loc = RawArchive -> ArchiveLocation
    raLocation RawArchive
    archive
          getFiles :: [ArchiveType] -> RIO env (ArchiveType, Map FilePath MetaEntry)
    getFiles [] = PantryException -> RIO env (ArchiveType, Map FilePath MetaEntry)
    forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
    throwIO (PantryException -> RIO env (ArchiveType, Map FilePath MetaEntry))
    -> PantryException -> RIO env (ArchiveType, Map FilePath MetaEntry)
    forall a b. (a -> b) -> a -> b
    $ ArchiveLocation -> PantryException
    UnknownArchiveType ArchiveLocation
    loc
          getFiles (at :: ArchiveType
    at:ats :: [ArchiveType]
    ats) = do
            Either SomeException ([MetaEntry] -> [MetaEntry])
    eres <- RIO env ([MetaEntry] -> [MetaEntry])
    -> RIO env (Either SomeException ([MetaEntry] -> [MetaEntry]))
    forall (m :: * -> *) a.
    MonadUnliftIO m =>
    m a -> m (Either SomeException a)
    tryAny (RIO env ([MetaEntry] -> [MetaEntry])
     -> RIO env (Either SomeException ([MetaEntry] -> [MetaEntry])))
    -> RIO env ([MetaEntry] -> [MetaEntry])
    -> RIO env (Either SomeException ([MetaEntry] -> [MetaEntry]))
    forall a b. (a -> b) -> a -> b
    $ ArchiveLocation
    -> FilePath
    -> ArchiveType
    -> ([MetaEntry] -> [MetaEntry])
    -> (([MetaEntry] -> [MetaEntry])
        -> MetaEntry
        -> ConduitT ByteString Void (RIO env) ([MetaEntry] -> [MetaEntry]))
    -> RIO env ([MetaEntry] -> [MetaEntry])
    forall env a.
    (HasPantryConfig env, HasLogFunc env) =>
    ArchiveLocation
    -> FilePath
    -> ArchiveType
    -> a
    -> (a -> MetaEntry -> ConduitT ByteString Void (RIO env) a)
    -> RIO env a
    foldArchive ArchiveLocation
    loc FilePath
    fp ArchiveType
    at [MetaEntry] -> [MetaEntry]
    forall a. a -> a
    id ((([MetaEntry] -> [MetaEntry])
      -> MetaEntry
      -> ConduitT ByteString Void (RIO env) ([MetaEntry] -> [MetaEntry]))
     -> RIO env ([MetaEntry] -> [MetaEntry]))
    -> (([MetaEntry] -> [MetaEntry])
        -> MetaEntry
        -> ConduitT ByteString Void (RIO env) ([MetaEntry] -> [MetaEntry]))
    -> RIO env ([MetaEntry] -> [MetaEntry])
    forall a b. (a -> b) -> a -> b
    $ \m :: [MetaEntry] -> [MetaEntry]
    m me :: MetaEntry
    me -> ([MetaEntry] -> [MetaEntry])
    -> ConduitT ByteString Void (RIO env) ([MetaEntry] -> [MetaEntry])
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (([MetaEntry] -> [MetaEntry])
     -> ConduitT ByteString Void (RIO env) ([MetaEntry] -> [MetaEntry]))
    -> ([MetaEntry] -> [MetaEntry])
    -> ConduitT ByteString Void (RIO env) ([MetaEntry] -> [MetaEntry])
    forall a b. (a -> b) -> a -> b
    $ [MetaEntry] -> [MetaEntry]
    m ([MetaEntry] -> [MetaEntry])
    -> ([MetaEntry] -> [MetaEntry]) -> [MetaEntry] -> [MetaEntry]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (MetaEntry
    meMetaEntry -> [MetaEntry] -> [MetaEntry]
    forall a. a -> [a] -> [a]
    :)
            case Either SomeException ([MetaEntry] -> [MetaEntry])
    eres of
              Left e :: SomeException
    e -> do
                Utf8Builder -> RIO env ()
    forall (m :: * -> *) env.
    (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
    Utf8Builder -> m ()
    logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
    forall a b. (a -> b) -> a -> b
    $ "parseArchive of " Utf8Builder -> Utf8Builder -> Utf8Builder
    forall a. Semigroup a => a -> a -> a
    <> ArchiveType -> Utf8Builder
    forall a. Display a => a -> Utf8Builder
    display ArchiveType
    at Utf8Builder -> Utf8Builder -> Utf8Builder
    forall a. Semigroup a => a -> a -> a
    <> ": " Utf8Builder -> Utf8Builder -> Utf8Builder
    forall a. Semigroup a => a -> a -> a
    <> SomeException -> Utf8Builder
    forall a. Show a => a -> Utf8Builder
    displayShow SomeException
    e
                [ArchiveType] -> RIO env (ArchiveType, Map FilePath MetaEntry)
    getFiles [ArchiveType]
    ats
              Right files :: [MetaEntry] -> [MetaEntry]
    files -> (ArchiveType, Map FilePath MetaEntry)
    -> RIO env (ArchiveType, Map FilePath MetaEntry)
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (ArchiveType
    at, [(FilePath, MetaEntry)] -> Map FilePath MetaEntry
    forall k a. Ord k => [(k, a)] -> Map k a
    Map.fromList ([(FilePath, MetaEntry)] -> Map FilePath MetaEntry)
    -> [(FilePath, MetaEntry)] -> Map FilePath MetaEntry
    forall a b. (a -> b) -> a -> b
    $ (MetaEntry -> (FilePath, MetaEntry))
    -> [MetaEntry] -> [(FilePath, MetaEntry)]
    forall a b. (a -> b) -> [a] -> [b]
    map (MetaEntry -> FilePath
    mePath (MetaEntry -> FilePath)
    -> (MetaEntry -> MetaEntry) -> MetaEntry -> (FilePath, MetaEntry)
    forall (a :: * -> * -> *) b c c'.
    Arrow a =>
    a b c -> a b c' -> a b (c, c')
    &&& MetaEntry -> MetaEntry
    forall a. a -> a
    id) ([MetaEntry] -> [(FilePath, MetaEntry)])
    -> [MetaEntry] -> [(FilePath, MetaEntry)]
    forall a b. (a -> b) -> a -> b
    $ [MetaEntry] -> [MetaEntry]
    files [])
      (ArchiveType
    at :: ArchiveType, Map FilePath MetaEntry
    files :: Map FilePath MetaEntry) <- [ArchiveType] -> RIO env (ArchiveType, Map FilePath MetaEntry)
    forall env.
    (HasPantryConfig env, HasLogFunc env) =>
    [ArchiveType] -> RIO env (ArchiveType, Map FilePath MetaEntry)
    getFiles [ArchiveType
    forall a. Bounded a => a
    minBound..ArchiveType
    forall a. Bounded a => a
    maxBound]
      let toSimple :: FilePath -> MetaEntry -> Either String (Map FilePath SimpleEntry)
          toSimple :: FilePath -> MetaEntry -> Either FilePath (Map FilePath SimpleEntry)
    toSimple key :: FilePath
    key me :: MetaEntry
    me =
            case MetaEntry -> METype
    meType MetaEntry
    me of
              METNormal -> Map FilePath SimpleEntry
    -> Either FilePath (Map FilePath SimpleEntry)
    forall a b. b -> Either a b
    Right (Map FilePath SimpleEntry
     -> Either FilePath (Map FilePath SimpleEntry))
    -> Map FilePath SimpleEntry
    -> Either FilePath (Map FilePath SimpleEntry)
    forall a b. (a -> b) -> a -> b
    $ FilePath -> SimpleEntry -> Map FilePath SimpleEntry
    forall k a. k -> a -> Map k a
    Map.singleton FilePath
    key (SimpleEntry -> Map FilePath SimpleEntry)
    -> SimpleEntry -> Map FilePath SimpleEntry
    forall a b. (a -> b) -> a -> b
    $ FilePath -> FileType -> SimpleEntry
    SimpleEntry (MetaEntry -> FilePath
    mePath MetaEntry
    me) FileType
    FTNormal
              METExecutable -> Map FilePath SimpleEntry
    -> Either FilePath (Map FilePath SimpleEntry)
    forall a b. b -> Either a b
    Right (Map FilePath SimpleEntry
     -> Either FilePath (Map FilePath SimpleEntry))
    -> Map FilePath SimpleEntry
    -> Either FilePath (Map FilePath SimpleEntry)
    forall a b. (a -> b) -> a -> b
    $ FilePath -> SimpleEntry -> Map FilePath SimpleEntry
    forall k a. k -> a -> Map k a
    Map.singleton FilePath
    key (SimpleEntry -> Map FilePath SimpleEntry)
    -> SimpleEntry -> Map FilePath SimpleEntry
    forall a b. (a -> b) -> a -> b
    $ FilePath -> FileType -> SimpleEntry
    SimpleEntry (MetaEntry -> FilePath
    mePath MetaEntry
    me) FileType
    FTExecutable
              METLink relDest :: FilePath
    relDest -> do
                case FilePath
    relDest of
                  '/':_ -> FilePath -> Either FilePath ()
    forall a b. a -> Either a b
    Left (FilePath -> Either FilePath ()) -> FilePath -> Either FilePath ()
    forall a b. (a -> b) -> a -> b
    $ [FilePath] -> FilePath
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat
                             [ "File located at "
                             , ShowS
    forall a. Show a => a -> FilePath
    show ShowS -> ShowS
    forall a b. (a -> b) -> a -> b
    $ MetaEntry -> FilePath
    mePath MetaEntry
    me
                             , " is a symbolic link to absolute path "
                             , FilePath
    relDest
                             ]
                  _ -> () -> Either FilePath ()
    forall a b. b -> Either a b
    Right ()
                FilePath
    dest0 <-
                  case FilePath -> FilePath -> Either FilePath FilePath
    makeTarRelative (MetaEntry -> FilePath
    mePath MetaEntry
    me) FilePath
    relDest of
                    Left e :: FilePath
    e -> FilePath -> Either FilePath FilePath
    forall a b. a -> Either a b
    Left (FilePath -> Either FilePath FilePath)
    -> FilePath -> Either FilePath FilePath
    forall a b. (a -> b) -> a -> b
    $ [FilePath] -> FilePath
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat
                      [ "Error resolving relative path "
                      , FilePath
    relDest
                      , " from symlink at "
                      , MetaEntry -> FilePath
    mePath MetaEntry
    me
                      , ": "
                      , FilePath
    e
                      ]
                    Right x :: FilePath
    x -> FilePath -> Either FilePath FilePath
    forall a b. b -> Either a b
    Right FilePath
    x
                FilePath
    dest <-
                  case FilePath -> Either FilePath FilePath
    normalizeParents FilePath
    dest0 of
                    Left e :: FilePath
    e -> FilePath -> Either FilePath FilePath
    forall a b. a -> Either a b
    Left (FilePath -> Either FilePath FilePath)
    -> FilePath -> Either FilePath FilePath
    forall a b. (a -> b) -> a -> b
    $ [FilePath] -> FilePath
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat
                      [ "Invalid symbolic link from "
                      , MetaEntry -> FilePath
    mePath MetaEntry
    me
                      , " to "
                      , FilePath
    relDest
                      , ", tried parsing "
                      , FilePath
    dest0
                      , ": "
                      , FilePath
    e
                      ]
                    Right x :: FilePath
    x -> FilePath -> Either FilePath FilePath
    forall a b. b -> Either a b
    Right FilePath
    x
                -- Check if it's a symlink to a file
                case FilePath -> Map FilePath MetaEntry -> Maybe MetaEntry
    forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup FilePath
    dest Map FilePath MetaEntry
    files of
                  Nothing ->
                    -- Check if it's a symlink to a directory
                    case FilePath -> Map FilePath MetaEntry -> [(FilePath, MetaEntry)]
    findWithPrefix FilePath
    dest Map FilePath MetaEntry
    files of
                      [] -> FilePath -> Either FilePath (Map FilePath SimpleEntry)
    forall a b. a -> Either a b
    Left (FilePath -> Either FilePath (Map FilePath SimpleEntry))
    -> FilePath -> Either FilePath (Map FilePath SimpleEntry)
    forall a b. (a -> b) -> a -> b
    $ "Symbolic link dest not found from " FilePath -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ MetaEntry -> FilePath
    mePath MetaEntry
    me FilePath -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ " to " FilePath -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ FilePath
    relDest FilePath -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ ", looking for " FilePath -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ FilePath
    dest FilePath -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ ".\n"
                                FilePath -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ "This may indicate that the source is a git archive which uses git-annex.\n"
                                FilePath -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ "See https://github.com/commercialhaskell/stack/issues/4579 for further information."
                      pairs :: [(FilePath, MetaEntry)]
    pairs -> ([Map FilePath SimpleEntry] -> Map FilePath SimpleEntry)
    -> Either FilePath [Map FilePath SimpleEntry]
    -> Either FilePath (Map FilePath SimpleEntry)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap [Map FilePath SimpleEntry] -> Map FilePath SimpleEntry
    forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
    fold (Either FilePath [Map FilePath SimpleEntry]
     -> Either FilePath (Map FilePath SimpleEntry))
    -> Either FilePath [Map FilePath SimpleEntry]
    -> Either FilePath (Map FilePath SimpleEntry)
    forall a b. (a -> b) -> a -> b
    $ [(FilePath, MetaEntry)]
    -> ((FilePath, MetaEntry)
        -> Either FilePath (Map FilePath SimpleEntry))
    -> Either FilePath [Map FilePath SimpleEntry]
    forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    t a -> (a -> f b) -> f (t b)
    for [(FilePath, MetaEntry)]
    pairs (((FilePath, MetaEntry)
      -> Either FilePath (Map FilePath SimpleEntry))
     -> Either FilePath [Map FilePath SimpleEntry])
    -> ((FilePath, MetaEntry)
        -> Either FilePath (Map FilePath SimpleEntry))
    -> Either FilePath [Map FilePath SimpleEntry]
    forall a b. (a -> b) -> a -> b
    $ \(suffix :: FilePath
    suffix, me' :: MetaEntry
    me') -> FilePath -> MetaEntry -> Either FilePath (Map FilePath SimpleEntry)
    toSimple (FilePath
    key FilePath -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ '/' Char -> ShowS
    forall a. a -> [a] -> [a]
    : FilePath
    suffix) MetaEntry
    me'
                  Just me' :: MetaEntry
    me' ->
                    case MetaEntry -> METype
    meType MetaEntry
    me' of
                      METNormal -> Map FilePath SimpleEntry
    -> Either FilePath (Map FilePath SimpleEntry)
    forall a b. b -> Either a b
    Right (Map FilePath SimpleEntry
     -> Either FilePath (Map FilePath SimpleEntry))
    -> Map FilePath SimpleEntry
    -> Either FilePath (Map FilePath SimpleEntry)
    forall a b. (a -> b) -> a -> b
    $ FilePath -> SimpleEntry -> Map FilePath SimpleEntry
    forall k a. k -> a -> Map k a
    Map.singleton FilePath
    key (SimpleEntry -> Map FilePath SimpleEntry)
    -> SimpleEntry -> Map FilePath SimpleEntry
    forall a b. (a -> b) -> a -> b
    $ FilePath -> FileType -> SimpleEntry
    SimpleEntry FilePath
    dest FileType
    FTNormal
                      METExecutable -> Map FilePath SimpleEntry
    -> Either FilePath (Map FilePath SimpleEntry)
    forall a b. b -> Either a b
    Right (Map FilePath SimpleEntry
     -> Either FilePath (Map FilePath SimpleEntry))
    -> Map FilePath SimpleEntry
    -> Either FilePath (Map FilePath SimpleEntry)
    forall a b. (a -> b) -> a -> b
    $ FilePath -> SimpleEntry -> Map FilePath SimpleEntry
    forall k a. k -> a -> Map k a
    Map.singleton FilePath
    key (SimpleEntry -> Map FilePath SimpleEntry)
    -> SimpleEntry -> Map FilePath SimpleEntry
    forall a b. (a -> b) -> a -> b
    $ FilePath -> FileType -> SimpleEntry
    SimpleEntry FilePath
    dest FileType
    FTExecutable
                      METLink _ -> FilePath -> Either FilePath (Map FilePath SimpleEntry)
    forall a b. a -> Either a b
    Left (FilePath -> Either FilePath (Map FilePath SimpleEntry))
    -> FilePath -> Either FilePath (Map FilePath SimpleEntry)
    forall a b. (a -> b) -> a -> b
    $ "Symbolic link dest cannot be a symbolic link, from " FilePath -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ MetaEntry -> FilePath
    mePath MetaEntry
    me FilePath -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ " to " FilePath -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ FilePath
    relDest

      case Map FilePath (Map FilePath SimpleEntry) -> Map FilePath SimpleEntry
    forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
    fold (Map FilePath (Map FilePath SimpleEntry)
     -> Map FilePath SimpleEntry)
    -> Either FilePath (Map FilePath (Map FilePath SimpleEntry))
    -> Either FilePath (Map FilePath SimpleEntry)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (FilePath
     -> MetaEntry -> Either FilePath (Map FilePath SimpleEntry))
    -> Map FilePath MetaEntry
    -> Either FilePath (Map FilePath (Map FilePath SimpleEntry))
    forall (t :: * -> *) k a b.
    Applicative t =>
    (k -> a -> t b) -> Map k a -> t (Map k b)
    Map.traverseWithKey FilePath -> MetaEntry -> Either FilePath (Map FilePath SimpleEntry)
    toSimple Map FilePath MetaEntry
    files of
        Left e :: FilePath
    e -> PantryException -> RIO env Package
    forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
    throwIO (PantryException -> RIO env Package)
    -> PantryException -> RIO env Package
    forall a b. (a -> b) -> a -> b
    $ ArchiveLocation -> Text -> PantryException
    UnsupportedTarball ArchiveLocation
    loc (Text -> PantryException) -> Text -> PantryException
    forall a b. (a -> b) -> a -> b
    $ FilePath -> Text
    T.pack FilePath
    e
        Right files1 :: Map FilePath SimpleEntry
    files1 -> do
          let files2 :: [(FilePath, SimpleEntry)]
    files2 = [(FilePath, SimpleEntry)] -> [(FilePath, SimpleEntry)]
    forall a. [(FilePath, a)] -> [(FilePath, a)]
    stripCommonPrefix ([(FilePath, SimpleEntry)] -> [(FilePath, SimpleEntry)])
    -> [(FilePath, SimpleEntry)] -> [(FilePath, SimpleEntry)]
    forall a b. (a -> b) -> a -> b
    $ Map FilePath SimpleEntry -> [(FilePath, SimpleEntry)]
    forall k a. Map k a -> [(k, a)]
    Map.toList Map FilePath SimpleEntry
    files1
              files3 :: [(Text, SimpleEntry)]
    files3 = Text -> [(FilePath, SimpleEntry)] -> [(Text, SimpleEntry)]
    forall a. Text -> [(FilePath, a)] -> [(Text, a)]
    takeSubdir (RawArchive -> Text
    raSubdir RawArchive
    archive) [(FilePath, SimpleEntry)]
    files2
              toSafe :: (Text, b) -> Either FilePath (SafeFilePath, b)
    toSafe (fp' :: Text
    fp', a :: b
    a) =
                case Text -> Maybe SafeFilePath
    mkSafeFilePath Text
    fp' of
                  Nothing -> FilePath -> Either FilePath (SafeFilePath, b)
    forall a b. a -> Either a b
    Left (FilePath -> Either FilePath (SafeFilePath, b))
    -> FilePath -> Either FilePath (SafeFilePath, b)
    forall a b. (a -> b) -> a -> b
    $ "Not a safe file path: " FilePath -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Text -> FilePath
    forall a. Show a => a -> FilePath
    show Text
    fp'
                  Just sfp :: SafeFilePath
    sfp -> (SafeFilePath, b) -> Either FilePath (SafeFilePath, b)
    forall a b. b -> Either a b
    Right (SafeFilePath
    sfp, b
    a)
          case ((Text, SimpleEntry)
     -> Either FilePath (SafeFilePath, SimpleEntry))
    -> [(Text, SimpleEntry)]
    -> Either FilePath [(SafeFilePath, SimpleEntry)]
    forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    (a -> f b) -> t a -> f (t b)
    traverse (Text, SimpleEntry) -> Either FilePath (SafeFilePath, SimpleEntry)
    forall b. (Text, b) -> Either FilePath (SafeFilePath, b)
    toSafe [(Text, SimpleEntry)]
    files3 of
            Left e :: FilePath
    e -> PantryException -> RIO env Package
    forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
    throwIO (PantryException -> RIO env Package)
    -> PantryException -> RIO env Package
    forall a b. (a -> b) -> a -> b
    $ ArchiveLocation -> Text -> PantryException
    UnsupportedTarball ArchiveLocation
    loc (Text -> PantryException) -> Text -> PantryException
    forall a b. (a -> b) -> a -> b
    $ FilePath -> Text
    T.pack FilePath
    e
            Right safeFiles :: [(SafeFilePath, SimpleEntry)]
    safeFiles -> do
              let toSave :: Set FilePath
    toSave = [FilePath] -> Set FilePath
    forall a. Ord a => [a] -> Set a
    Set.fromList ([FilePath] -> Set FilePath) -> [FilePath] -> Set FilePath
    forall a b. (a -> b) -> a -> b
    $ ((SafeFilePath, SimpleEntry) -> FilePath)
    -> [(SafeFilePath, SimpleEntry)] -> [FilePath]
    forall a b. (a -> b) -> [a] -> [b]
    map (SimpleEntry -> FilePath
    seSource (SimpleEntry -> FilePath)
    -> ((SafeFilePath, SimpleEntry) -> SimpleEntry)
    -> (SafeFilePath, SimpleEntry)
    -> FilePath
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (SafeFilePath, SimpleEntry) -> SimpleEntry
    forall a b. (a, b) -> b
    snd) [(SafeFilePath, SimpleEntry)]
    safeFiles
              (Map FilePath BlobKey
    blobs :: Map FilePath BlobKey)  <-
                ArchiveLocation
    -> FilePath
    -> ArchiveType
    -> Map FilePath BlobKey
    -> (Map FilePath BlobKey
        -> MetaEntry
        -> ConduitT ByteString Void (RIO env) (Map FilePath BlobKey))
    -> RIO env (Map FilePath BlobKey)
    forall env a.
    (HasPantryConfig env, HasLogFunc env) =>
    ArchiveLocation
    -> FilePath
    -> ArchiveType
    -> a
    -> (a -> MetaEntry -> ConduitT ByteString Void (RIO env) a)
    -> RIO env a
    foldArchive ArchiveLocation
    loc FilePath
    fp ArchiveType
    at Map FilePath BlobKey
    forall a. Monoid a => a
    mempty ((Map FilePath BlobKey
      -> MetaEntry
      -> ConduitT ByteString Void (RIO env) (Map FilePath BlobKey))
     -> RIO env (Map FilePath BlobKey))
    -> (Map FilePath BlobKey
        -> MetaEntry
        -> ConduitT ByteString Void (RIO env) (Map FilePath BlobKey))
    -> RIO env (Map FilePath BlobKey)
    forall a b. (a -> b) -> a -> b
    $ \m :: Map FilePath BlobKey
    m me :: MetaEntry
    me ->
                  if MetaEntry -> FilePath
    mePath MetaEntry
    me FilePath -> Set FilePath -> Bool
    forall a. Ord a => a -> Set a -> Bool
    `Set.member` Set FilePath
    toSave
                    then do
                      ByteString
    bs <- [ByteString] -> ByteString
    forall a. Monoid a => [a] -> a
    mconcat ([ByteString] -> ByteString)
    -> ConduitT ByteString Void (RIO env) [ByteString]
    -> ConduitT ByteString Void (RIO env) ByteString
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ConduitT ByteString Void (RIO env) [ByteString]
    forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
    sinkList
                      (_, blobKey :: BlobKey
    blobKey) <- RIO env (BlobId, BlobKey)
    -> ConduitT ByteString Void (RIO env) (BlobId, BlobKey)
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (RIO env (BlobId, BlobKey)
     -> ConduitT ByteString Void (RIO env) (BlobId, BlobKey))
    -> RIO env (BlobId, BlobKey)
    -> ConduitT ByteString Void (RIO env) (BlobId, BlobKey)
    forall a b. (a -> b) -> a -> b
    $ ReaderT SqlBackend (RIO env) (BlobId, BlobKey)
    -> RIO env (BlobId, BlobKey)
    forall env a.
    (HasPantryConfig env, HasLogFunc env) =>
    ReaderT SqlBackend (RIO env) a -> RIO env a
    withStorage (ReaderT SqlBackend (RIO env) (BlobId, BlobKey)
     -> RIO env (BlobId, BlobKey))
    -> ReaderT SqlBackend (RIO env) (BlobId, BlobKey)
    -> RIO env (BlobId, BlobKey)
    forall a b. (a -> b) -> a -> b
    $ ByteString -> ReaderT SqlBackend (RIO env) (BlobId, BlobKey)
    forall env.
    ByteString -> ReaderT SqlBackend (RIO env) (BlobId, BlobKey)
    storeBlob ByteString
    bs
                      Map FilePath BlobKey
    -> ConduitT ByteString Void (RIO env) (Map FilePath BlobKey)
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Map FilePath BlobKey
     -> ConduitT ByteString Void (RIO env) (Map FilePath BlobKey))
    -> Map FilePath BlobKey
    -> ConduitT ByteString Void (RIO env) (Map FilePath BlobKey)
    forall a b. (a -> b) -> a -> b
    $ FilePath -> BlobKey -> Map FilePath BlobKey -> Map FilePath BlobKey
    forall k a. Ord k => k -> a -> Map k a -> Map k a
    Map.insert (MetaEntry -> FilePath
    mePath MetaEntry
    me) BlobKey
    blobKey Map FilePath BlobKey
    m
                    else Map FilePath BlobKey
    -> ConduitT ByteString Void (RIO env) (Map FilePath BlobKey)
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Map FilePath BlobKey
    m
              Tree
    tree <- ([(SafeFilePath, TreeEntry)] -> Tree)
    -> RIO env [(SafeFilePath, TreeEntry)] -> RIO env Tree
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (Map SafeFilePath TreeEntry -> Tree
    TreeMap (Map SafeFilePath TreeEntry -> Tree)
    -> ([(SafeFilePath, TreeEntry)] -> Map SafeFilePath TreeEntry)
    -> [(SafeFilePath, TreeEntry)]
    -> Tree
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [(SafeFilePath, TreeEntry)] -> Map SafeFilePath TreeEntry
    forall k a. Ord k => [(k, a)] -> Map k a
    Map.fromList) (RIO env [(SafeFilePath, TreeEntry)] -> RIO env Tree)
    -> RIO env [(SafeFilePath, TreeEntry)] -> RIO env Tree
    forall a b. (a -> b) -> a -> b
    $ [(SafeFilePath, SimpleEntry)]
    -> ((SafeFilePath, SimpleEntry)
        -> RIO env (SafeFilePath, TreeEntry))
    -> RIO env [(SafeFilePath, TreeEntry)]
    forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    t a -> (a -> f b) -> f (t b)
    for [(SafeFilePath, SimpleEntry)]
    safeFiles (((SafeFilePath, SimpleEntry) -> RIO env (SafeFilePath, TreeEntry))
     -> RIO env [(SafeFilePath, TreeEntry)])
    -> ((SafeFilePath, SimpleEntry)
        -> RIO env (SafeFilePath, TreeEntry))
    -> RIO env [(SafeFilePath, TreeEntry)]
    forall a b. (a -> b) -> a -> b
    $ \(sfp :: SafeFilePath
    sfp, se :: SimpleEntry
    se) ->
                case FilePath -> Map FilePath BlobKey -> Maybe BlobKey
    forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup (SimpleEntry -> FilePath
    seSource SimpleEntry
    se) Map FilePath BlobKey
    blobs of
                  Nothing -> FilePath -> RIO env (SafeFilePath, TreeEntry)
    forall a. HasCallStack => FilePath -> a
    error (FilePath -> RIO env (SafeFilePath, TreeEntry))
    -> FilePath -> RIO env (SafeFilePath, TreeEntry)
    forall a b. (a -> b) -> a -> b
    $ "Impossible: blob not found for: " FilePath -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ SimpleEntry -> FilePath
    seSource SimpleEntry
    se
                  Just blobKey :: BlobKey
    blobKey -> (SafeFilePath, TreeEntry) -> RIO env (SafeFilePath, TreeEntry)
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (SafeFilePath
    sfp, BlobKey -> FileType -> TreeEntry
    TreeEntry BlobKey
    blobKey (SimpleEntry -> FileType
    seType SimpleEntry
    se))
              -- parse the cabal file and ensure it has the right name
              BuildFile
    buildFile <- RawPackageLocationImmutable -> Tree -> RIO env BuildFile
    forall (m :: * -> *).
    MonadThrow m =>
    RawPackageLocationImmutable -> Tree -> m BuildFile
    findCabalOrHpackFile RawPackageLocationImmutable
    rpli Tree
    tree
              (buildFilePath :: SafeFilePath
    buildFilePath, buildFileBlobKey :: BlobKey
    buildFileBlobKey, buildFileEntry :: TreeEntry
    buildFileEntry) <- case BuildFile
    buildFile of
                                                                     BFCabal fpath :: SafeFilePath
    fpath te :: TreeEntry
    te@(TreeEntry key :: BlobKey
    key _) -> (SafeFilePath, BlobKey, TreeEntry)
    -> RIO env (SafeFilePath, BlobKey, TreeEntry)
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (SafeFilePath
    fpath, BlobKey
    key, TreeEntry
    te)
                                                                     BFHpack te :: TreeEntry
    te@(TreeEntry key :: BlobKey
    key _) -> (SafeFilePath, BlobKey, TreeEntry)
    -> RIO env (SafeFilePath, BlobKey, TreeEntry)
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (SafeFilePath
    hpackSafeFilePath, BlobKey
    key, TreeEntry
    te)
              Maybe ByteString
    mbs <- ReaderT SqlBackend (RIO env) (Maybe ByteString)
    -> RIO env (Maybe ByteString)
    forall env a.
    (HasPantryConfig env, HasLogFunc env) =>
    ReaderT SqlBackend (RIO env) a -> RIO env a
    withStorage (ReaderT SqlBackend (RIO env) (Maybe ByteString)
     -> RIO env (Maybe ByteString))
    -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
    -> RIO env (Maybe ByteString)
    forall a b. (a -> b) -> a -> b
    $ BlobKey -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
    forall env.
    HasLogFunc env =>
    BlobKey -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
    loadBlob BlobKey
    buildFileBlobKey
              ByteString
    bs <-
                case Maybe ByteString
    mbs of
                  Nothing -> PantryException -> RIO env ByteString
    forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
    throwIO (PantryException -> RIO env ByteString)
    -> PantryException -> RIO env ByteString
    forall a b. (a -> b) -> a -> b
    $ RawPackageLocationImmutable
    -> SafeFilePath -> BlobKey -> PantryException
    TreeReferencesMissingBlob RawPackageLocationImmutable
    rpli SafeFilePath
    buildFilePath BlobKey
    buildFileBlobKey
                  Just bs :: ByteString
    bs -> ByteString -> RIO env ByteString
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ByteString
    bs
              ByteString
    cabalBs <- case BuildFile
    buildFile of
                BFCabal _ _ -> ByteString -> RIO env ByteString
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ByteString
    bs
                BFHpack _ -> (PackageName, ByteString) -> ByteString
    forall a b. (a, b) -> b
    snd ((PackageName, ByteString) -> ByteString)
    -> RIO env (PackageName, ByteString) -> RIO env ByteString
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> RawPackageLocationImmutable
    -> Tree -> RIO env (PackageName, ByteString)
    forall env.
    (HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
    RawPackageLocationImmutable
    -> Tree -> RIO env (PackageName, ByteString)
    hpackToCabal RawPackageLocationImmutable
    rpli Tree
    tree
              (_warnings :: [PWarning]
    _warnings, gpd :: GenericPackageDescription
    gpd) <- Either RawPackageLocationImmutable (Path Abs File)
    -> ByteString -> RIO env ([PWarning], GenericPackageDescription)
    forall (m :: * -> *).
    MonadThrow m =>
    Either RawPackageLocationImmutable (Path Abs File)
    -> ByteString -> m ([PWarning], GenericPackageDescription)
    rawParseGPD (RawPackageLocationImmutable
    -> Either RawPackageLocationImmutable (Path Abs File)
    forall a b. a -> Either a b
    Left RawPackageLocationImmutable
    rpli) ByteString
    cabalBs
              let ident :: PackageIdentifier
    ident@(PackageIdentifier name :: PackageName
    name _) = PackageDescription -> PackageIdentifier
    package (PackageDescription -> PackageIdentifier)
    -> PackageDescription -> PackageIdentifier
    forall a b. (a -> b) -> a -> b
    $ GenericPackageDescription -> PackageDescription
    packageDescription GenericPackageDescription
    gpd
              case BuildFile
    buildFile of
                BFCabal _ _ -> Bool -> RIO env () -> RIO env ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (SafeFilePath
    buildFilePath SafeFilePath -> SafeFilePath -> Bool
    forall a. Eq a => a -> a -> Bool
    /= PackageName -> SafeFilePath
    cabalFileName PackageName
    name) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
    forall a b. (a -> b) -> a -> b
    $ PantryException -> RIO env ()
    forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
    throwIO (PantryException -> RIO env ()) -> PantryException -> RIO env ()
    forall a b. (a -> b) -> a -> b
    $ RawPackageLocationImmutable
    -> SafeFilePath -> PackageName -> PantryException
    WrongCabalFileName RawPackageLocationImmutable
    rpli SafeFilePath
    buildFilePath PackageName
    name
                _ -> () -> RIO env ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
              -- It's good! Store the tree, let's bounce
              (tid :: TreeId
    tid, treeKey' :: TreeKey
    treeKey') <- ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
    -> RIO env (TreeId, TreeKey)
    forall env a.
    (HasPantryConfig env, HasLogFunc env) =>
    ReaderT SqlBackend (RIO env) a -> RIO env a
    withStorage (ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
     -> RIO env (TreeId, TreeKey))
    -> ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
    -> RIO env (TreeId, TreeKey)
    forall a b. (a -> b) -> a -> b
    $ RawPackageLocationImmutable
    -> PackageIdentifier
    -> Tree
    -> BuildFile
    -> ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
    forall env.
    (HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
    RawPackageLocationImmutable
    -> PackageIdentifier
    -> Tree
    -> BuildFile
    -> ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
    storeTree RawPackageLocationImmutable
    rpli PackageIdentifier
    ident Tree
    tree BuildFile
    buildFile
              PackageCabal
    packageCabal <- case BuildFile
    buildFile of
                                BFCabal _ _ -> PackageCabal -> RIO env PackageCabal
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (PackageCabal -> RIO env PackageCabal)
    -> PackageCabal -> RIO env PackageCabal
    forall a b. (a -> b) -> a -> b
    $ TreeEntry -> PackageCabal
    PCCabalFile TreeEntry
    buildFileEntry
                                BFHpack _ -> do
                                  BlobKey
    cabalKey <- ReaderT SqlBackend (RIO env) BlobKey -> RIO env BlobKey
    forall env a.
    (HasPantryConfig env, HasLogFunc env) =>
    ReaderT SqlBackend (RIO env) a -> RIO env a
    withStorage (ReaderT SqlBackend (RIO env) BlobKey -> RIO env BlobKey)
    -> ReaderT SqlBackend (RIO env) BlobKey -> RIO env BlobKey
    forall a b. (a -> b) -> a -> b
    $ do
                                                Key HPack
    hpackId <- RawPackageLocationImmutable
    -> TreeId -> ReaderT SqlBackend (RIO env) (Key HPack)
    forall env.
    (HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
    RawPackageLocationImmutable
    -> TreeId -> ReaderT SqlBackend (RIO env) (Key HPack)
    storeHPack RawPackageLocationImmutable
    rpli TreeId
    tid
                                                Key HPack -> ReaderT SqlBackend (RIO env) BlobKey
    forall env. Key HPack -> ReaderT SqlBackend (RIO env) BlobKey
    loadCabalBlobKey Key HPack
    hpackId
                                  Version
    hpackSoftwareVersion <- RIO env Version
    forall env.
    (HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
    RIO env Version
    hpackVersion
                                  let cabalTreeEntry :: TreeEntry
    cabalTreeEntry = BlobKey -> FileType -> TreeEntry
    TreeEntry BlobKey
    cabalKey (TreeEntry -> FileType
    teType TreeEntry
    buildFileEntry)
                                  PackageCabal -> RIO env PackageCabal
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (PackageCabal -> RIO env PackageCabal)
    -> PackageCabal -> RIO env PackageCabal
    forall a b. (a -> b) -> a -> b
    $ PHpack -> PackageCabal
    PCHpack (PHpack -> PackageCabal) -> PHpack -> PackageCabal
    forall a b. (a -> b) -> a -> b
    $ $WPHpack :: TreeEntry -> TreeEntry -> Version -> PHpack
    PHpack { phOriginal :: TreeEntry
    phOriginal = TreeEntry
    buildFileEntry, phGenerated :: TreeEntry
    phGenerated = TreeEntry
    cabalTreeEntry, phVersion :: Version
    phVersion = Version
    hpackSoftwareVersion}
              Package -> RIO env Package
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure $WPackage :: TreeKey -> Tree -> PackageCabal -> PackageIdentifier -> Package
    Package
                { packageTreeKey :: TreeKey
    packageTreeKey = TreeKey
    treeKey'
                , packageTree :: Tree
    packageTree = Tree
    tree
                , packageCabalEntry :: PackageCabal
    packageCabalEntry = PackageCabal
    packageCabal
                , packageIdent :: PackageIdentifier
    packageIdent = PackageIdentifier
    ident
                }

    -- | Find all of the files in the Map with the given directory as a
    -- prefix. Directory is given without trailing slash. Returns the
    -- suffix after stripping the given prefix.
    findWithPrefix :: FilePath -> Map FilePath MetaEntry -> [(FilePath, MetaEntry)]
    findWithPrefix :: FilePath -> Map FilePath MetaEntry -> [(FilePath, MetaEntry)]
    findWithPrefix dir :: FilePath
    dir = ((FilePath, MetaEntry) -> Maybe (FilePath, MetaEntry))
    -> [(FilePath, MetaEntry)] -> [(FilePath, MetaEntry)]
    forall a b. (a -> Maybe b) -> [a] -> [b]
    mapMaybe (FilePath, MetaEntry) -> Maybe (FilePath, MetaEntry)
    forall t. (FilePath, t) -> Maybe (FilePath, t)
    go ([(FilePath, MetaEntry)] -> [(FilePath, MetaEntry)])
    -> (Map FilePath MetaEntry -> [(FilePath, MetaEntry)])
    -> Map FilePath MetaEntry
    -> [(FilePath, MetaEntry)]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Map FilePath MetaEntry -> [(FilePath, MetaEntry)]
    forall k a. Map k a -> [(k, a)]
    Map.toList
      where
        prefix :: FilePath
    prefix = FilePath
    dir FilePath -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ "/"
        go :: (FilePath, t) -> Maybe (FilePath, t)
    go (x :: FilePath
    x, y :: t
    y) = (, t
    y) (FilePath -> (FilePath, t))
    -> Maybe FilePath -> Maybe (FilePath, t)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> FilePath -> FilePath -> Maybe FilePath
    forall a. Eq a => [a] -> [a] -> Maybe [a]
    List.stripPrefix FilePath
    prefix FilePath
    x

    findCabalOrHpackFile
      :: MonadThrow m
      => RawPackageLocationImmutable -- ^ for exceptions
      -> Tree
      -> m BuildFile
    findCabalOrHpackFile :: RawPackageLocationImmutable -> Tree -> m BuildFile
    findCabalOrHpackFile loc :: RawPackageLocationImmutable
    loc (TreeMap m :: Map SafeFilePath TreeEntry
    m) = do
      let isCabalFile :: (SafeFilePath, b) -> Bool
    isCabalFile (sfp :: SafeFilePath
    sfp, _) =
            let txt :: Text
    txt = SafeFilePath -> Text
    unSafeFilePath SafeFilePath
    sfp
             in Bool -> Bool
    not ("/" Text -> Text -> Bool
    `T.isInfixOf` Text
    txt) Bool -> Bool -> Bool
    && (".cabal" Text -> Text -> Bool
    `T.isSuffixOf` Text
    txt)
          isHpackFile :: (SafeFilePath, b) -> Bool
    isHpackFile (sfp :: SafeFilePath
    sfp, _) =
            let txt :: Text
    txt = SafeFilePath -> Text
    unSafeFilePath SafeFilePath
    sfp
             in FilePath -> Text
    T.pack (FilePath
    Hpack.packageConfig) Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    == Text
    txt
          isBFCabal :: BuildFile -> Bool
    isBFCabal (BFCabal _ _) = Bool
    True
          isBFCabal _ = Bool
    False
          sfpBuildFile :: BuildFile -> SafeFilePath
    sfpBuildFile (BFCabal sfp :: SafeFilePath
    sfp _) = SafeFilePath
    sfp
          sfpBuildFile (BFHpack _) = SafeFilePath
    hpackSafeFilePath
          toBuildFile :: (SafeFilePath, TreeEntry) -> Maybe BuildFile
    toBuildFile xs :: (SafeFilePath, TreeEntry)
    xs@(sfp :: SafeFilePath
    sfp, te :: TreeEntry
    te) = let cbFile :: Maybe BuildFile
    cbFile = if ((SafeFilePath, TreeEntry) -> Bool
    forall b. (SafeFilePath, b) -> Bool
    isCabalFile (SafeFilePath, TreeEntry)
    xs)
                                                  then BuildFile -> Maybe BuildFile
    forall a. a -> Maybe a
    Just (BuildFile -> Maybe BuildFile) -> BuildFile -> Maybe BuildFile
    forall a b. (a -> b) -> a -> b
    $ SafeFilePath -> TreeEntry -> BuildFile
    BFCabal SafeFilePath
    sfp TreeEntry
    te
                                                  else Maybe BuildFile
    forall a. Maybe a
    Nothing
                                         hpFile :: Maybe BuildFile
    hpFile = if ((SafeFilePath, TreeEntry) -> Bool
    forall b. (SafeFilePath, b) -> Bool
    isHpackFile (SafeFilePath, TreeEntry)
    xs)
                                                  then BuildFile -> Maybe BuildFile
    forall a. a -> Maybe a
    Just (BuildFile -> Maybe BuildFile) -> BuildFile -> Maybe BuildFile
    forall a b. (a -> b) -> a -> b
    $ TreeEntry -> BuildFile
    BFHpack TreeEntry
    te
                                                  else Maybe BuildFile
    forall a. Maybe a
    Nothing
                                     in Maybe BuildFile
    cbFile Maybe BuildFile -> Maybe BuildFile -> Maybe BuildFile
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> Maybe BuildFile
    hpFile
      case ((SafeFilePath, TreeEntry) -> Maybe BuildFile)
    -> [(SafeFilePath, TreeEntry)] -> [BuildFile]
    forall a b. (a -> Maybe b) -> [a] -> [b]
    mapMaybe (SafeFilePath, TreeEntry) -> Maybe BuildFile
    toBuildFile ([(SafeFilePath, TreeEntry)] -> [BuildFile])
    -> [(SafeFilePath, TreeEntry)] -> [BuildFile]
    forall a b. (a -> b) -> a -> b
    $ Map SafeFilePath TreeEntry -> [(SafeFilePath, TreeEntry)]
    forall k a. Map k a -> [(k, a)]
    Map.toList Map SafeFilePath TreeEntry
    m of
        [] -> PantryException -> m BuildFile
    forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
    throwM (PantryException -> m BuildFile) -> PantryException -> m BuildFile
    forall a b. (a -> b) -> a -> b
    $ RawPackageLocationImmutable -> PantryException
    TreeWithoutCabalFile RawPackageLocationImmutable
    loc
        [bfile :: BuildFile
    bfile] -> BuildFile -> m BuildFile
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure BuildFile
    bfile
        xs :: [BuildFile]
    xs -> case ((BuildFile -> Bool) -> [BuildFile] -> [BuildFile]
    forall a. (a -> Bool) -> [a] -> [a]
    filter BuildFile -> Bool
    isBFCabal [BuildFile]
    xs) of
                [] -> PantryException -> m BuildFile
    forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
    throwM (PantryException -> m BuildFile) -> PantryException -> m BuildFile
    forall a b. (a -> b) -> a -> b
    $ RawPackageLocationImmutable -> PantryException
    TreeWithoutCabalFile RawPackageLocationImmutable
    loc
                [bfile :: BuildFile
    bfile] -> BuildFile -> m BuildFile
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure BuildFile
    bfile
                xs' :: [BuildFile]
    xs' -> PantryException -> m BuildFile
    forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
    throwM (PantryException -> m BuildFile) -> PantryException -> m BuildFile
    forall a b. (a -> b) -> a -> b
    $ RawPackageLocationImmutable -> [SafeFilePath] -> PantryException
    TreeWithMultipleCabalFiles RawPackageLocationImmutable
    loc ([SafeFilePath] -> PantryException)
    -> [SafeFilePath] -> PantryException
    forall a b. (a -> b) -> a -> b
    $ (BuildFile -> SafeFilePath) -> [BuildFile] -> [SafeFilePath]
    forall a b. (a -> b) -> [a] -> [b]
    map BuildFile -> SafeFilePath
    sfpBuildFile [BuildFile]
    xs'

    -- | If all files have a shared prefix, strip it off
    stripCommonPrefix :: [(FilePath, a)] -> [(FilePath, a)]
    stripCommonPrefix :: [(FilePath, a)] -> [(FilePath, a)]
    stripCommonPrefix [] = []
    stripCommonPrefix pairs :: [(FilePath, a)]
    pairs@((firstFP :: FilePath
    firstFP, _):_) = [(FilePath, a)] -> Maybe [(FilePath, a)] -> [(FilePath, a)]
    forall a. a -> Maybe a -> a
    fromMaybe [(FilePath, a)]
    pairs (Maybe [(FilePath, a)] -> [(FilePath, a)])
    -> Maybe [(FilePath, a)] -> [(FilePath, a)]
    forall a b. (a -> b) -> a -> b
    $ do
      let firstDir :: FilePath
    firstDir = (Char -> Bool) -> ShowS
    forall a. (a -> Bool) -> [a] -> [a]
    takeWhile (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /= '/') FilePath
    firstFP
      Bool -> Maybe ()
    forall (f :: * -> *). Alternative f => Bool -> f ()
    guard (Bool -> Maybe ()) -> Bool -> Maybe ()
    forall a b. (a -> b) -> a -> b
    $ Bool -> Bool
    not (Bool -> Bool) -> Bool -> Bool
    forall a b. (a -> b) -> a -> b
    $ FilePath -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null FilePath
    firstDir
      let strip :: (FilePath, t) -> Maybe (FilePath, t)
    strip (fp :: FilePath
    fp, a :: t
    a) = (, t
    a) (FilePath -> (FilePath, t))
    -> Maybe FilePath -> Maybe (FilePath, t)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> FilePath -> FilePath -> Maybe FilePath
    forall a. Eq a => [a] -> [a] -> Maybe [a]
    List.stripPrefix (FilePath
    firstDir FilePath -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ "/") FilePath
    fp
      [(FilePath, a)] -> [(FilePath, a)]
    forall a. [(FilePath, a)] -> [(FilePath, a)]
    stripCommonPrefix ([(FilePath, a)] -> [(FilePath, a)])
    -> Maybe [(FilePath, a)] -> Maybe [(FilePath, a)]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ((FilePath, a) -> Maybe (FilePath, a))
    -> [(FilePath, a)] -> Maybe [(FilePath, a)]
    forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    (a -> f b) -> t a -> f (t b)
    traverse (FilePath, a) -> Maybe (FilePath, a)
    forall t. (FilePath, t) -> Maybe (FilePath, t)
    strip [(FilePath, a)]
    pairs

    -- | Take us down to the specified subdirectory
    takeSubdir
      :: Text -- ^ subdir
      -> [(FilePath, a)] -- ^ files after stripping common prefix
      -> [(Text, a)]
    takeSubdir :: Text -> [(FilePath, a)] -> [(Text, a)]
    takeSubdir subdir :: Text
    subdir = ((FilePath, a) -> Maybe (Text, a))
    -> [(FilePath, a)] -> [(Text, a)]
    forall a b. (a -> Maybe b) -> [a] -> [b]
    mapMaybe (((FilePath, a) -> Maybe (Text, a))
     -> [(FilePath, a)] -> [(Text, a)])
    -> ((FilePath, a) -> Maybe (Text, a))
    -> [(FilePath, a)]
    -> [(Text, a)]
    forall a b. (a -> b) -> a -> b
    $ \(fp :: FilePath
    fp, a :: a
    a) -> do
      [Text]
    stripped <- [Text] -> [Text] -> Maybe [Text]
    forall a. Eq a => [a] -> [a] -> Maybe [a]
    List.stripPrefix [Text]
    subdirs ([Text] -> Maybe [Text]) -> [Text] -> Maybe [Text]
    forall a b. (a -> b) -> a -> b
    $ Text -> [Text]
    splitDirs (Text -> [Text]) -> Text -> [Text]
    forall a b. (a -> b) -> a -> b
    $ FilePath -> Text
    T.pack FilePath
    fp
      (Text, a) -> Maybe (Text, a)
    forall a. a -> Maybe a
    Just (Text -> [Text] -> Text
    T.intercalate "/" [Text]
    stripped, a
    a)
      where
        splitDirs :: Text -> [Text]
    splitDirs = (Text -> Bool) -> [Text] -> [Text]
    forall a. (a -> Bool) -> [a] -> [a]
    List.dropWhile (Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    == ".") ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Text -> Bool) -> [Text] -> [Text]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    /= "") ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Text -> Text -> [Text]
    T.splitOn "/"
        subdirs :: [Text]
    subdirs = Text -> [Text]
    splitDirs Text
    subdir