{-# 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 [(RawArchive, RawPackageMetadata)]
pairs =
  [(RawArchive, RawPackageMetadata)]
-> ((RawArchive, RawPackageMetadata)
    -> RIO env (SHA256, FileSize, Package, CachedTree))
-> 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, CachedTree))
 -> RIO env ())
-> ((RawArchive, RawPackageMetadata)
    -> RIO env (SHA256, FileSize, Package, CachedTree))
-> RIO env ()
forall a b. (a -> b) -> a -> b
$ \(RawArchive
ra, RawPackageMetadata
rpm) ->
    RawPackageLocationImmutable
-> RawArchive
-> RawPackageMetadata
-> RIO env (SHA256, FileSize, Package, CachedTree)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env,
 HasCallStack) =>
RawPackageLocationImmutable
-> RawArchive
-> RawPackageMetadata
-> RIO env (SHA256, FileSize, Package, CachedTree)
getArchive (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 [(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) | (Archive
a, 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 RawPackageLocationImmutable
rpli RawArchive
archive 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

thd4 :: (a, b, c, d) -> c
thd4 :: (a, b, c, d) -> c
thd4 (a
_, b
_, c
z, d
_) = 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 RawPackageLocationImmutable
rpli RawArchive
archive RawPackageMetadata
rpm = (SHA256, FileSize, Package, CachedTree) -> Package
forall a b c d. (a, b, c, d) -> c
thd4 ((SHA256, FileSize, Package, CachedTree) -> Package)
-> RIO env (SHA256, FileSize, Package, CachedTree)
-> RIO env Package
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawPackageLocationImmutable
-> RawArchive
-> RawPackageMetadata
-> RIO env (SHA256, FileSize, Package, CachedTree)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env,
 HasCallStack) =>
RawPackageLocationImmutable
-> RawArchive
-> RawPackageMetadata
-> RIO env (SHA256, FileSize, Package, CachedTree)
getArchive RawPackageLocationImmutable
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, CachedTree)
getArchive :: RawPackageLocationImmutable
-> RawArchive
-> RawPackageMetadata
-> RIO env (SHA256, FileSize, Package, CachedTree)
getArchive RawPackageLocationImmutable
rpli RawArchive
archive RawPackageMetadata
rpm = do
  -- Check if the value is in the cache, 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
  -- Ensure that all of the blobs referenced exist in the cache
  -- See: https://github.com/commercialhaskell/pantry/issues/27
  Maybe CachedTree
mtree <-
    case Maybe (SHA256, FileSize, Package)
mcached of
      Maybe (SHA256, FileSize, Package)
Nothing -> Maybe CachedTree -> RIO env (Maybe CachedTree)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CachedTree
forall a. Maybe a
Nothing
      Just (SHA256
_, FileSize
_, Package
pa) -> do
        Either LoadCachedTreeException CachedTree
etree <- ReaderT
  SqlBackend (RIO env) (Either LoadCachedTreeException CachedTree)
-> RIO env (Either LoadCachedTreeException CachedTree)
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT
   SqlBackend (RIO env) (Either LoadCachedTreeException CachedTree)
 -> RIO env (Either LoadCachedTreeException CachedTree))
-> ReaderT
     SqlBackend (RIO env) (Either LoadCachedTreeException CachedTree)
-> RIO env (Either LoadCachedTreeException CachedTree)
forall a b. (a -> b) -> a -> b
$ Tree
-> ReaderT
     SqlBackend (RIO env) (Either LoadCachedTreeException CachedTree)
forall env.
Tree
-> ReaderT
     SqlBackend (RIO env) (Either LoadCachedTreeException CachedTree)
loadCachedTree (Tree
 -> ReaderT
      SqlBackend (RIO env) (Either LoadCachedTreeException CachedTree))
-> Tree
-> ReaderT
     SqlBackend (RIO env) (Either LoadCachedTreeException CachedTree)
forall a b. (a -> b) -> a -> b
$ Package -> Tree
packageTree Package
pa
        case Either LoadCachedTreeException CachedTree
etree of
          Left LoadCachedTreeException
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
$ Utf8Builder
"getArchive of " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> RawPackageLocationImmutable -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow RawPackageLocationImmutable
rpli Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": loadCachedTree failed: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> LoadCachedTreeException -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow LoadCachedTreeException
e
            Maybe CachedTree -> RIO env (Maybe CachedTree)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CachedTree
forall a. Maybe a
Nothing
          Right CachedTree
x -> Maybe CachedTree -> RIO env (Maybe CachedTree)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe CachedTree -> RIO env (Maybe CachedTree))
-> Maybe CachedTree -> RIO env (Maybe CachedTree)
forall a b. (a -> b) -> a -> b
$ CachedTree -> Maybe CachedTree
forall a. a -> Maybe a
Just CachedTree
x
  cached :: (SHA256, FileSize, Package, CachedTree)
cached@(SHA256
_, FileSize
_, Package
pa, CachedTree
_) <-
    case (Maybe (SHA256, FileSize, Package)
mcached, Maybe CachedTree
mtree) of
      (Just (SHA256
a, FileSize
b, Package
c), Just CachedTree
d) -> (SHA256, FileSize, Package, CachedTree)
-> RIO env (SHA256, FileSize, Package, CachedTree)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SHA256
a, FileSize
b, Package
c, CachedTree
d)
      -- Not in the archive. Load the archive. Completely ignore the
      -- PackageMetadata for now, we'll check that the Package
      -- info matches next.
      (Maybe (SHA256, FileSize, Package), Maybe CachedTree)
_ -> RawArchive
-> (FilePath
    -> SHA256
    -> FileSize
    -> RIO env (SHA256, FileSize, Package, CachedTree))
-> RIO env (SHA256, FileSize, Package, CachedTree)
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, CachedTree))
 -> RIO env (SHA256, FileSize, Package, CachedTree))
-> (FilePath
    -> SHA256
    -> FileSize
    -> RIO env (SHA256, FileSize, Package, CachedTree))
-> RIO env (SHA256, FileSize, Package, CachedTree)
forall a b. (a -> b) -> a -> b
$ \FilePath
fp SHA256
sha FileSize
size -> do
        (Package
pa, CachedTree
tree) <- RawPackageLocationImmutable
-> RawArchive -> FilePath -> RIO env (Package, CachedTree)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> RawArchive -> FilePath -> RIO env (Package, CachedTree)
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, CachedTree)
-> RIO env (SHA256, FileSize, Package, CachedTree)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SHA256
sha, FileSize
size, Package
pa, CachedTree
tree)

  (PantryException
 -> RIO env (SHA256, FileSize, Package, CachedTree))
-> (Package -> RIO env (SHA256, FileSize, Package, CachedTree))
-> Either PantryException Package
-> RIO env (SHA256, FileSize, Package, CachedTree)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either PantryException -> RIO env (SHA256, FileSize, Package, CachedTree)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (\Package
_ -> (SHA256, FileSize, Package, CachedTree)
-> RIO env (SHA256, FileSize, Package, CachedTree)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SHA256, FileSize, Package, CachedTree)
cached) (Either PantryException Package
 -> RIO env (SHA256, FileSize, Package, CachedTree))
-> Either PantryException Package
-> RIO env (SHA256, FileSize, Package, CachedTree)
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 RawArchive
archive SHA256
sha FileSize
size Package
pa =
  case RawArchive -> ArchiveLocation
raLocation RawArchive
archive of
    ALUrl 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 ResolvedPath File
_ -> () -> 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 RawPackageLocationImmutable
rpli RawArchive
archive =
  case ArchiveLocation
loc of
    ALFilePath ResolvedPath File
_ -> 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 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 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 ((SHA256
sha, FileSize
size, TreeId
tid):[(SHA256, FileSize, TreeId)]
rest) =
      case Maybe SHA256
msha of
        Maybe SHA256
Nothing -> do
          case Maybe FileSize
msize of
            Just 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
            Maybe FileSize
_ -> do
              case ArchiveLocation
loc of
                ALUrl 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
$ Utf8Builder
"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
<> Utf8Builder
" 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
$ Utf8Builder
"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
<> Utf8Builder
", file size " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> FileSize -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display FileSize
size
                ALFilePath ResolvedPath File
_ -> () -> 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 SHA256
sha'
          | SHA256
sha SHA256 -> SHA256 -> Bool
forall a. Eq a => a -> a -> Bool
== SHA256
sha' ->
              case Maybe FileSize
msize of
                Maybe FileSize
Nothing -> do
                  case ArchiveLocation
loc of
                    -- Only debug level, let lock files solve this
                    ALUrl 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
$ Utf8Builder
"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
<> Utf8Builder
" does not specify a size"
                    ALFilePath ResolvedPath File
_ -> () -> 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 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
$ Utf8Builder
"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
<> Utf8Builder
" has a matching hash but mismatched size"
                      Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"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 RawPackageLocationImmutable
pl RawPackageMetadata
pm 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 a
x) a
y = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y
      test Maybe a
Nothing a
_ = 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 ResolvedPath File
resolved) Maybe SHA256
msha Maybe FileSize
msize Text
_subdir) 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'
  (SHA256
sha, 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
$ \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
$ \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' Mismatch :: 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
$ \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' Mismatch :: 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 Text
url) Maybe SHA256
msha Maybe FileSize
msize Text
_subdir) 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 FilePath
"archive" ((FilePath -> Handle -> RIO env a) -> RIO env a)
-> (FilePath -> Handle -> RIO env a) -> RIO env a
forall a b. (a -> b) -> a -> b
$ \FilePath
fp 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
$ Utf8Builder
"Downloading archive from " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
url
    (SHA256
sha, 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 ArchiveType
ATTarGz = Utf8Builder
"GZIP-ed tar file"
  display ArchiveType
ATTar = Utf8Builder
"Uncompressed tar file"
  display ArchiveType
ATZip = Utf8Builder
"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 ArchiveLocation
loc FilePath
fp ArchiveType
ATTarGz a
accum 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
$ \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 ArchiveLocation
loc FilePath
fp ArchiveType
ATTar a
accum 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
$ \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 ArchiveLocation
loc FilePath
fp ArchiveType
ATZip a
accum0 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
$ \Handle
h -> do
  let go :: a -> Entry -> RIO env a
go a
accum 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) Int
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
.&. Word16
0xFF00 Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
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
/= Word32
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
.&. Word32
0o100) Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
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) Mismatch :: 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 =
        case ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Entry -> FilePath
Zip.eRelativePath Entry
entry of
          Char
'/':FilePath
_ -> Bool
True
          FilePath
_ -> 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 ArchiveLocation
loc a
accum0 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
$ \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_ (\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 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 ByteString
bs ->
            case ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
bs of
              Left UnicodeException
_ -> PantryException -> m (Maybe METype)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO PantryException
exc
              Right 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
          FileType
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
.&. FileMode
0o100 FileMode -> FileMode -> Bool
forall a. Eq a => a -> a -> Bool
/= FileMode
0
              then METype
METExecutable
              else METype
METNormal
          FileType
Tar.FTDirectory -> Maybe METype -> m (Maybe METype)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe METype
forall a. Maybe a
Nothing
          FileType
_ -> 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
$
        (\METype
met -> MetaEntry :: 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, CachedTree)
parseArchive :: RawPackageLocationImmutable
-> RawArchive -> FilePath -> RIO env (Package, CachedTree)
parseArchive RawPackageLocationImmutable
rpli RawArchive
archive 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 (ArchiveType
at:[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
$ \[MetaEntry] -> [MetaEntry]
m 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 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
$ Utf8Builder
"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 -> 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 [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 FilePath
key MetaEntry
me =
        case MetaEntry -> METype
meType MetaEntry
me of
          METype
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
          METype
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 FilePath
relDest -> do
            case FilePath
relDest of
              Char
'/':FilePath
_ -> 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
                         [ FilePath
"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
                         , FilePath
" is a symbolic link to absolute path "
                         , FilePath
relDest
                         ]
              FilePath
_ -> () -> 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 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
                  [ FilePath
"Error resolving relative path "
                  , FilePath
relDest
                  , FilePath
" from symlink at "
                  , MetaEntry -> FilePath
mePath MetaEntry
me
                  , FilePath
": "
                  , FilePath
e
                  ]
                Right 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 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
                  [ FilePath
"Invalid symbolic link from "
                  , MetaEntry -> FilePath
mePath MetaEntry
me
                  , FilePath
" to "
                  , FilePath
relDest
                  , FilePath
", tried parsing "
                  , FilePath
dest0
                  , FilePath
": "
                  , FilePath
e
                  ]
                Right 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
              Maybe MetaEntry
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
$ FilePath
"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]
++ FilePath
" to " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
relDest FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
", looking for " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
dest FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
".\n"
                            FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"This may indicate that the source is a git archive which uses git-annex.\n"
                            FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"See https://github.com/commercialhaskell/stack/issues/4579 for further information."
                  [(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
$ \(FilePath
suffix, MetaEntry
me') -> FilePath -> MetaEntry -> Either FilePath (Map FilePath SimpleEntry)
toSimple (FilePath
key FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'/' Char -> ShowS
forall a. a -> [a] -> [a]
: FilePath
suffix) MetaEntry
me'
              Just MetaEntry
me' ->
                case MetaEntry -> METype
meType MetaEntry
me' of
                  METype
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
                  METype
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
_ -> 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
$ FilePath
"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]
++ FilePath
" 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 FilePath
e -> PantryException -> RIO env (Package, CachedTree)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env (Package, CachedTree))
-> PantryException -> RIO env (Package, CachedTree)
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 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 (Text
fp', b
a) =
            case Text -> Maybe SafeFilePath
mkSafeFilePath Text
fp' of
              Maybe SafeFilePath
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
$ FilePath
"Not a safe file path: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
forall a. Show a => a -> FilePath
show Text
fp'
              Just 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 FilePath
e -> PantryException -> RIO env (Package, CachedTree)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env (Package, CachedTree))
-> PantryException -> RIO env (Package, CachedTree)
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 [(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, BlobId)
blobs :: Map FilePath (BlobKey, BlobId))  <-
            ArchiveLocation
-> FilePath
-> ArchiveType
-> Map FilePath (BlobKey, BlobId)
-> (Map FilePath (BlobKey, BlobId)
    -> MetaEntry
    -> ConduitT
         ByteString Void (RIO env) (Map FilePath (BlobKey, BlobId)))
-> RIO env (Map FilePath (BlobKey, BlobId))
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, BlobId)
forall a. Monoid a => a
mempty ((Map FilePath (BlobKey, BlobId)
  -> MetaEntry
  -> ConduitT
       ByteString Void (RIO env) (Map FilePath (BlobKey, BlobId)))
 -> RIO env (Map FilePath (BlobKey, BlobId)))
-> (Map FilePath (BlobKey, BlobId)
    -> MetaEntry
    -> ConduitT
         ByteString Void (RIO env) (Map FilePath (BlobKey, BlobId)))
-> RIO env (Map FilePath (BlobKey, BlobId))
forall a b. (a -> b) -> a -> b
$ \Map FilePath (BlobKey, BlobId)
m 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
                  (BlobId
blobId, 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, BlobId)
-> ConduitT
     ByteString Void (RIO env) (Map FilePath (BlobKey, BlobId))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map FilePath (BlobKey, BlobId)
 -> ConduitT
      ByteString Void (RIO env) (Map FilePath (BlobKey, BlobId)))
-> Map FilePath (BlobKey, BlobId)
-> ConduitT
     ByteString Void (RIO env) (Map FilePath (BlobKey, BlobId))
forall a b. (a -> b) -> a -> b
$ FilePath
-> (BlobKey, BlobId)
-> Map FilePath (BlobKey, BlobId)
-> Map FilePath (BlobKey, BlobId)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (MetaEntry -> FilePath
mePath MetaEntry
me) (BlobKey
blobKey, BlobId
blobId) Map FilePath (BlobKey, BlobId)
m
                else Map FilePath (BlobKey, BlobId)
-> ConduitT
     ByteString Void (RIO env) (Map FilePath (BlobKey, BlobId))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map FilePath (BlobKey, BlobId)
m
          CachedTree
tree :: CachedTree <- ([(SafeFilePath, (TreeEntry, BlobId))] -> CachedTree)
-> RIO env [(SafeFilePath, (TreeEntry, BlobId))]
-> RIO env CachedTree
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map SafeFilePath (TreeEntry, BlobId) -> CachedTree
CachedTreeMap (Map SafeFilePath (TreeEntry, BlobId) -> CachedTree)
-> ([(SafeFilePath, (TreeEntry, BlobId))]
    -> Map SafeFilePath (TreeEntry, BlobId))
-> [(SafeFilePath, (TreeEntry, BlobId))]
-> CachedTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SafeFilePath, (TreeEntry, BlobId))]
-> Map SafeFilePath (TreeEntry, BlobId)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList) (RIO env [(SafeFilePath, (TreeEntry, BlobId))]
 -> RIO env CachedTree)
-> RIO env [(SafeFilePath, (TreeEntry, BlobId))]
-> RIO env CachedTree
forall a b. (a -> b) -> a -> b
$ [(SafeFilePath, SimpleEntry)]
-> ((SafeFilePath, SimpleEntry)
    -> RIO env (SafeFilePath, (TreeEntry, BlobId)))
-> RIO env [(SafeFilePath, (TreeEntry, BlobId))]
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, BlobId)))
 -> RIO env [(SafeFilePath, (TreeEntry, BlobId))])
-> ((SafeFilePath, SimpleEntry)
    -> RIO env (SafeFilePath, (TreeEntry, BlobId)))
-> RIO env [(SafeFilePath, (TreeEntry, BlobId))]
forall a b. (a -> b) -> a -> b
$ \(SafeFilePath
sfp, SimpleEntry
se) ->
            case FilePath
-> Map FilePath (BlobKey, BlobId) -> Maybe (BlobKey, BlobId)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (SimpleEntry -> FilePath
seSource SimpleEntry
se) Map FilePath (BlobKey, BlobId)
blobs of
              Maybe (BlobKey, BlobId)
Nothing -> FilePath -> RIO env (SafeFilePath, (TreeEntry, BlobId))
forall a. HasCallStack => FilePath -> a
error (FilePath -> RIO env (SafeFilePath, (TreeEntry, BlobId)))
-> FilePath -> RIO env (SafeFilePath, (TreeEntry, BlobId))
forall a b. (a -> b) -> a -> b
$ FilePath
"Impossible: blob not found for: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ SimpleEntry -> FilePath
seSource SimpleEntry
se
              Just (BlobKey
blobKey, BlobId
blobId) -> (SafeFilePath, (TreeEntry, BlobId))
-> RIO env (SafeFilePath, (TreeEntry, BlobId))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SafeFilePath
sfp, (BlobKey -> FileType -> TreeEntry
TreeEntry BlobKey
blobKey (SimpleEntry -> FileType
seType SimpleEntry
se), BlobId
blobId))
          -- 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 -> RIO env BuildFile) -> Tree -> RIO env BuildFile
forall a b. (a -> b) -> a -> b
$ CachedTree -> Tree
unCachedTree CachedTree
tree
          (SafeFilePath
buildFilePath, BlobKey
buildFileBlobKey, TreeEntry
buildFileEntry) <- case BuildFile
buildFile of
                                                                 BFCabal SafeFilePath
fpath te :: TreeEntry
te@(TreeEntry BlobKey
key FileType
_) -> (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 BlobKey
key FileType
_) -> (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
              Maybe ByteString
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 ByteString
bs -> ByteString -> RIO env ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs
          ByteString
cabalBs <- case BuildFile
buildFile of
            BFCabal SafeFilePath
_ TreeEntry
_ -> ByteString -> RIO env ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs
            BFHpack TreeEntry
_ -> (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 (CachedTree -> Tree
unCachedTree CachedTree
tree)
          ([PWarning]
_warnings, GenericPackageDescription
gpd) <- Either RawPackageLocationImmutable (Path Abs File)
-> ByteString -> RIO env ([PWarning], GenericPackageDescription)
forall (m :: * -> *).
MonadThrow m =>
Either RawPackageLocationImmutable (Path Abs File)
-> ByteString -> m ([PWarning], GenericPackageDescription)
rawParseGPD (RawPackageLocationImmutable
-> Either RawPackageLocationImmutable (Path Abs File)
forall a b. a -> Either a b
Left RawPackageLocationImmutable
rpli) ByteString
cabalBs
          let ident :: PackageIdentifier
ident@(PackageIdentifier PackageName
name Version
_) = PackageDescription -> PackageIdentifier
package (PackageDescription -> PackageIdentifier)
-> PackageDescription -> PackageIdentifier
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
packageDescription GenericPackageDescription
gpd
          case BuildFile
buildFile of
            BFCabal SafeFilePath
_ TreeEntry
_ -> 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
            BuildFile
_ -> () -> RIO env ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          -- It's good! Store the tree, let's bounce
          (TreeId
tid, 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
-> CachedTree
-> BuildFile
-> ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> PackageIdentifier
-> CachedTree
-> BuildFile
-> ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
storeTree RawPackageLocationImmutable
rpli PackageIdentifier
ident CachedTree
tree BuildFile
buildFile
          PackageCabal
packageCabal <- case BuildFile
buildFile of
                            BFCabal SafeFilePath
_ TreeEntry
_ -> 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 TreeEntry
_ -> 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
$ PHpack :: TreeEntry -> TreeEntry -> Version -> PHpack
PHpack { phOriginal :: TreeEntry
phOriginal = TreeEntry
buildFileEntry, phGenerated :: TreeEntry
phGenerated = TreeEntry
cabalTreeEntry, phVersion :: Version
phVersion = Version
hpackSoftwareVersion}
          (Package, CachedTree) -> RIO env (Package, CachedTree)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Package :: TreeKey -> Tree -> PackageCabal -> PackageIdentifier -> Package
Package
            { packageTreeKey :: TreeKey
packageTreeKey = TreeKey
treeKey'
            , packageTree :: Tree
packageTree = CachedTree -> Tree
unCachedTree CachedTree
tree
            , packageCabalEntry :: PackageCabal
packageCabalEntry = PackageCabal
packageCabal
            , packageIdent :: PackageIdentifier
packageIdent = PackageIdentifier
ident
            }, CachedTree
tree)

-- | 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 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]
++ FilePath
"/"
    go :: (FilePath, t) -> Maybe (FilePath, t)
go (FilePath
x, 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 RawPackageLocationImmutable
loc (TreeMap Map SafeFilePath TreeEntry
m) = do
  let isCabalFile :: (SafeFilePath, b) -> Bool
isCabalFile (SafeFilePath
sfp, b
_) =
        let txt :: Text
txt = SafeFilePath -> Text
unSafeFilePath SafeFilePath
sfp
         in Bool -> Bool
not (Text
"/" Text -> Text -> Bool
`T.isInfixOf` Text
txt) Bool -> Bool -> Bool
&& (Text
".cabal" Text -> Text -> Bool
`T.isSuffixOf` Text
txt)
      isHpackFile :: (SafeFilePath, b) -> Bool
isHpackFile (SafeFilePath
sfp, b
_) =
        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 SafeFilePath
_ TreeEntry
_) = Bool
True
      isBFCabal BuildFile
_ = Bool
False
      sfpBuildFile :: BuildFile -> SafeFilePath
sfpBuildFile (BFCabal SafeFilePath
sfp TreeEntry
_) = SafeFilePath
sfp
      sfpBuildFile (BFHpack TreeEntry
_) = SafeFilePath
hpackSafeFilePath
      toBuildFile :: (SafeFilePath, TreeEntry) -> Maybe BuildFile
toBuildFile xs :: (SafeFilePath, TreeEntry)
xs@(SafeFilePath
sfp, 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
    [BuildFile
bfile] -> BuildFile -> m BuildFile
forall (f :: * -> *) a. Applicative f => a -> f a
pure BuildFile
bfile
    [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
            [BuildFile
bfile] -> BuildFile -> m BuildFile
forall (f :: * -> *) a. Applicative f => a -> f a
pure BuildFile
bfile
            [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@((FilePath
firstFP, a
_):[(FilePath, a)]
_) = [(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
/= Char
'/') 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 (FilePath
fp, 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
"/") 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 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
$ \(FilePath
fp, 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
"/" [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 -> [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 -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> [Text]
T.splitOn Text
"/"
    subdirs :: [Text]
subdirs = Text -> [Text]
splitDirs Text
subdir