{-# 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, findOrGenerateCabalFile)
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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
[(RawArchive, RawPackageMetadata)] -> RIO env ()
fetchArchivesRaw [(RawArchive, RawPackageMetadata)]
pairs =
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(RawArchive, RawPackageMetadata)]
pairs forall a b. (a -> b) -> a -> b
$ \(RawArchive
ra, RawPackageMetadata
rpm) ->
    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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
[(Archive, PackageMetadata)] -> RIO env ()
fetchArchives [(Archive, PackageMetadata)]
pairs =
  -- TODO be more efficient, group together shared archives

  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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> RawArchive -> RawPackageMetadata -> RIO env TreeKey
getArchiveKey RawPackageLocationImmutable
rpli RawArchive
archive RawPackageMetadata
rpm =
  Package -> TreeKey
packageTreeKey forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 :: forall a b c d. (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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env,
 HasCallStack) =>
RawPackageLocationImmutable
-> RawArchive -> RawPackageMetadata -> RIO env Package
getArchivePackage RawPackageLocationImmutable
rpli RawArchive
archive RawPackageMetadata
rpm = forall a b c d. (a, b, c, d) -> c
thd4 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 :: 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 = do
  -- Check if the value is in the cache, and use it if possible

  Maybe (SHA256, FileSize, Package)
mcached <- 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
      Just (SHA256
_, FileSize
_, Package
pa) -> do
        Either LoadCachedTreeException CachedTree
etree <- forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage forall a b. (a -> b) -> a -> b
$ forall env.
Tree
-> ReaderT
     SqlBackend (RIO env) (Either LoadCachedTreeException CachedTree)
loadCachedTree forall a b. (a -> b) -> a -> b
$ Package -> Tree
packageTree Package
pa
        case Either LoadCachedTreeException CachedTree
etree of
          Left LoadCachedTreeException
e -> do
            forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"getArchive of " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow RawPackageLocationImmutable
rpli forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": loadCachedTree failed: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow LoadCachedTreeException
e
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
          Right CachedTree
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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) -> 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)
_ -> forall env a.
HasLogFunc env =>
RawArchive
-> (FilePath -> SHA256 -> FileSize -> RIO env a) -> RIO env a
withArchiveLoc RawArchive
archive forall a b. (a -> b) -> a -> b
$ \FilePath
fp SHA256
sha FileSize
size -> do
        (Package
pa, CachedTree
tree) <- 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.

        forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawArchive -> SHA256 -> FileSize -> Package -> RIO env ()
storeCache RawArchive
archive SHA256
sha FileSize
size Package
pa
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (SHA256
sha, FileSize
size, Package
pa, CachedTree
tree)

  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (\Package
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (SHA256, FileSize, Package, CachedTree)
cached) 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 :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
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 -> forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage forall a b. (a -> b) -> a -> b
$ forall env.
Text
-> 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
_ -> 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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> RawArchive -> RIO env (Maybe (SHA256, FileSize, Package))
loadCache RawPackageLocationImmutable
rpli RawArchive
archive =
  case ArchiveLocation
loc of
    ALFilePath ResolvedPath File
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing -- TODO can we do something intelligent here?

    ALUrl Text
url -> forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (forall env.
Text
-> Text
-> ReaderT SqlBackend (RIO env) [(SHA256, FileSize, TreeId)]
loadArchiveCache Text
url (RawArchive -> Text
raSubdir RawArchive
archive)) 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage forall a b. (a -> b) -> a -> b
$ forall env.
(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 [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 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

                  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Using archive from " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
url forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" without a specified cryptographic hash"
                  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Cached hash is " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display SHA256
sha forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", file size " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display FileSize
size
                ALFilePath ResolvedPath File
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SHA256
sha, FileSize
size,) 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 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 -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Archive from " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
url forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" does not specify a size"
                    ALFilePath ResolvedPath File
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SHA256
sha, FileSize
size,) 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 forall a. Eq a => a -> a -> Bool
== FileSize
size' -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SHA256
sha, FileSize
size,) 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

                      forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Archive from " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display ArchiveLocation
loc forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" has a matching hash but mismatched size"
                      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
              (forall a. a -> Maybe a
Just (Package -> TreeKey
packageTreeKey Package
pa))
              (Package -> PackageIdentifier
packageIdent Package
pa)

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

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

   in if forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
tests then forall a b. b -> Either a b
Right Package
pa else 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 :: forall env a.
HasLogFunc env =>
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' = forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath File
resolved
      fp :: FilePath
fp = forall b t. Path b t -> FilePath
toFilePath Path Abs File
abs'
  (SHA256
sha, FileSize
size) <- forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> IOMode -> (Handle -> m a) -> m a
withBinaryFile FilePath
fp IOMode
ReadMode forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
    FileSize
size <- Word -> FileSize
FileSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadIO m => Handle -> m Integer
hFileSize Handle
h
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe FileSize
msize forall a b. (a -> b) -> a -> b
$ \FileSize
size' -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FileSize
size forall a. Eq a => a -> a -> Bool
/= FileSize
size') forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Path Abs File -> Mismatch FileSize -> PantryException
LocalInvalidSize Path Abs File
abs' Mismatch
      { mismatchExpected :: FileSize
mismatchExpected = FileSize
size'
      , mismatchActual :: FileSize
mismatchActual = FileSize
size
      }

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

    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 =
  forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> (FilePath -> Handle -> m a) -> m a
withSystemTempFile FilePath
"archive" forall a b. (a -> b) -> a -> b
$ \FilePath
fp Handle
hout -> do
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Downloading archive from " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
url
    (SHA256
sha, FileSize
size, ()) <- forall (m :: * -> *) a.
MonadUnliftIO m =>
Text
-> Maybe SHA256
-> Maybe FileSize
-> ConduitT ByteString Void m a
-> m (SHA256, FileSize, a)
httpSinkChecked Text
url Maybe SHA256
msha Maybe FileSize
msize (forall (m :: * -> *) o.
MonadIO m =>
Handle -> ConduitT ByteString o m ()
sinkHandle Handle
hout)
    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]
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
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
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
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 :: 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
ATTarGz a
accum a -> MetaEntry -> ConduitT ByteString Void (RIO env) a
f =
  forall (m :: * -> *) (n :: * -> *) i a.
(MonadUnliftIO m, MonadIO n) =>
FilePath -> (ConduitM i ByteString n () -> m a) -> m a
withSourceFile FilePath
fp forall a b. (a -> b) -> a -> b
$ \ConduitM () ByteString (RIO env) ()
src -> forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ ConduitM () ByteString (RIO env) ()
src forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *).
(PrimMonad m, MonadThrow m) =>
ConduitT ByteString ByteString m ()
ungzip forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| 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 =
  forall (m :: * -> *) (n :: * -> *) i a.
(MonadUnliftIO m, MonadIO n) =>
FilePath -> (ConduitM i ByteString n () -> m a) -> m a
withSourceFile FilePath
fp forall a b. (a -> b) -> a -> b
$ \ConduitM () ByteString (RIO env) ()
src -> forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ ConduitM () ByteString (RIO env) ()
src forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| 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 = forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> IOMode -> (Handle -> m a) -> m a
withBinaryFile FilePath
fp IOMode
ReadMode 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 = forall a. a -> Maybe a -> a
fromMaybe METype
METNormal forall a b. (a -> b) -> a -> b
$ do
              let modes :: Word32
modes = forall a. Bits a => a -> Int -> a
shiftR (Entry -> Word32
Zip.eExternalFileAttributes Entry
entry) Int
16
              forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Entry -> Word16
Zip.eVersionMadeBy Entry
entry forall a. Bits a => a -> a -> a
.&. Word16
0xFF00 forall a. Eq a => a -> a -> Bool
== Word16
0x0300
              forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Word32
modes forall a. Eq a => a -> a -> Bool
/= Word32
0
              forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                if (Word32
modes forall a. Bits a => a -> a -> a
.&. Word32
0o100) 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 = forall a. CRC32 a => a -> Word32
CRC32.crc32 ByteString
lbs
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word32
crcExpected forall a. Eq a => a -> a -> Bool
/= Word32
crcActual)
          forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ ArchiveLocation -> FilePath -> Mismatch Word32 -> PantryException
CRC32Mismatch ArchiveLocation
loc (Entry -> FilePath
Zip.eRelativePath Entry
entry) Mismatch
              { mismatchExpected :: Word32
mismatchExpected = Word32
crcExpected
              , mismatchActual :: Word32
mismatchActual = Word32
crcActual
              }
        forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) lazy strict i.
(Monad m, LazySequence lazy strict) =>
lazy -> ConduitT i strict m ()
sourceLazy ByteString
lbs forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| a -> MetaEntry -> ConduitT ByteString Void (RIO env) a
f a
accum MetaEntry
me
      isDir :: Entry -> Bool
isDir Entry
entry =
        case forall a. [a] -> [a]
reverse 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 <- forall (m :: * -> *). MonadIO m => Handle -> m ByteString
BL.hGetContents Handle
h
  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 (forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entry -> Bool
isDir) forall a b. (a -> b) -> a -> b
$ Archive -> [Entry]
Zip.zEntries 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 :: 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
accum0 a -> MetaEntry -> ConduitT ByteString o (RIO env) a
f = do
  IORef a
ref <- forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef a
accum0
  forall (m :: * -> *) o.
MonadThrow m =>
(FileInfo -> ConduitM ByteString o m ())
-> ConduitM ByteString o m ()
Tar.untar forall a b. (a -> b) -> a -> b
$ \FileInfo
fi -> forall (m :: * -> *). MonadIO m => FileInfo -> m (Maybe MetaEntry)
toME FileInfo
fi forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\MetaEntry
me -> do
    a
accum <- 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
    forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef a
ref forall a b. (a -> b) -> a -> b
$! a
accum')
  forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef a
ref
  where
    toME :: MonadIO m => Tar.FileInfo -> m (Maybe MetaEntry)
    toME :: forall (m :: * -> *). MonadIO m => 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
_ -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO PantryException
exc
              Right Text
text -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ FilePath -> METype
METLink forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
text
          FileType
Tar.FTNormal -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
            if FileInfo -> FileMode
Tar.fileMode FileInfo
fi forall a. Bits a => a -> a -> a
.&. FileMode
0o100 forall a. Eq a => a -> a -> Bool
/= FileMode
0
              then METype
METExecutable
              else METype
METNormal
          FileType
Tar.FTDirectory -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
          FileType
_ -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO PantryException
exc
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        (\METype
met -> MetaEntry
          { mePath :: FilePath
mePath = FileInfo -> FilePath
Tar.getFileInfoPath FileInfo
fi
          , meType :: METype
meType = METype
met
          })
        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
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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
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 [] = forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ ArchiveLocation -> PantryException
UnknownArchiveType ArchiveLocation
loc
      getFiles (ArchiveType
at:[ArchiveType]
ats) = do
        Either SomeException ([MetaEntry] -> [MetaEntry])
eres <- forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny forall a b. (a -> b) -> a -> b
$ 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 forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ \[MetaEntry] -> [MetaEntry]
m MetaEntry
me -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [MetaEntry] -> [MetaEntry]
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MetaEntry
meforall a. a -> [a] -> [a]
:)
        case Either SomeException ([MetaEntry] -> [MetaEntry])
eres of
          Left SomeException
e -> do
            forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"parseArchive of " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display ArchiveType
at forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow SomeException
e
            [ArchiveType] -> RIO env (ArchiveType, Map FilePath MetaEntry)
getFiles [ArchiveType]
ats
          Right [MetaEntry] -> [MetaEntry]
files -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (ArchiveType
at, forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (MetaEntry -> FilePath
mePath forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$ [MetaEntry] -> [MetaEntry]
files [])
  (ArchiveType
at :: ArchiveType, Map FilePath MetaEntry
files :: Map FilePath MetaEntry) <- forall {env}.
(HasPantryConfig env, HasLogFunc env) =>
[ArchiveType] -> RIO env (ArchiveType, Map FilePath MetaEntry)
getFiles [forall a. Bounded a => a
minBound..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 -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton FilePath
key forall a b. (a -> b) -> a -> b
$ FilePath -> FileType -> SimpleEntry
SimpleEntry (MetaEntry -> FilePath
mePath MetaEntry
me) FileType
FTNormal
          METype
METExecutable -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton FilePath
key 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
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                         [ FilePath
"File located at "
                         , forall a. Show a => a -> FilePath
show forall a b. (a -> b) -> a -> b
$ MetaEntry -> FilePath
mePath MetaEntry
me
                         , FilePath
" is a symbolic link to absolute path "
                         , FilePath
relDest
                         ]
              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 -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ 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 -> forall a b. b -> Either a b
Right FilePath
x
            FilePath
dest <-
              case FilePath -> Either FilePath FilePath
normalizeParents FilePath
dest0 of
                Left FilePath
e -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ 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 -> forall a b. b -> Either a b
Right FilePath
x
            -- Check if it's a symlink to a file

            case 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
                  [] -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ FilePath
"Symbolic link dest not found from " forall a. [a] -> [a] -> [a]
++ MetaEntry -> FilePath
mePath MetaEntry
me forall a. [a] -> [a] -> [a]
++ FilePath
" to " forall a. [a] -> [a] -> [a]
++ FilePath
relDest forall a. [a] -> [a] -> [a]
++ FilePath
", looking for " forall a. [a] -> [a] -> [a]
++ FilePath
dest forall a. [a] -> [a] -> [a]
++ FilePath
".\n"
                            forall a. [a] -> [a] -> [a]
++ FilePath
"This may indicate that the source is a git archive which uses git-annex.\n"
                            forall a. [a] -> [a] -> [a]
++ FilePath
"See https://github.com/commercialhaskell/stack/issues/4579 for further information."
                  [(FilePath, MetaEntry)]
pairs -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(FilePath, MetaEntry)]
pairs forall a b. (a -> b) -> a -> b
$ \(FilePath
suffix, MetaEntry
me') -> FilePath -> MetaEntry -> Either FilePath (Map FilePath SimpleEntry)
toSimple (FilePath
key forall a. [a] -> [a] -> [a]
++ Char
'/' forall a. a -> [a] -> [a]
: FilePath
suffix) MetaEntry
me'
              Just MetaEntry
me' ->
                case MetaEntry -> METype
meType MetaEntry
me' of
                  METype
METNormal -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton FilePath
key forall a b. (a -> b) -> a -> b
$ FilePath -> FileType -> SimpleEntry
SimpleEntry FilePath
dest FileType
FTNormal
                  METype
METExecutable -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton FilePath
key forall a b. (a -> b) -> a -> b
$ FilePath -> FileType -> SimpleEntry
SimpleEntry FilePath
dest FileType
FTExecutable
                  METLink FilePath
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ FilePath
"Symbolic link dest cannot be a symbolic link, from " forall a. [a] -> [a] -> [a]
++ MetaEntry -> FilePath
mePath MetaEntry
me forall a. [a] -> [a] -> [a]
++ FilePath
" to " forall a. [a] -> [a] -> [a]
++ FilePath
relDest

  case forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ ArchiveLocation -> Text -> PantryException
UnsupportedTarball ArchiveLocation
loc forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
e
    Right Map FilePath SimpleEntry
files1 -> do
      let files2 :: [(FilePath, SimpleEntry)]
files2 = forall a. [(FilePath, a)] -> [(FilePath, a)]
stripCommonPrefix forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map FilePath SimpleEntry
files1
          files3 :: [(Text, SimpleEntry)]
files3 = 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 -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ FilePath
"Not a safe file path: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Text
fp'
              Just SafeFilePath
sfp -> forall a b. b -> Either a b
Right (SafeFilePath
sfp, b
a)
      case forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {b}. (Text, b) -> Either FilePath (SafeFilePath, b)
toSafe [(Text, SimpleEntry)]
files3 of
        Left FilePath
e -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ ArchiveLocation -> Text -> PantryException
UnsupportedTarball ArchiveLocation
loc forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
e
        Right [(SafeFilePath, SimpleEntry)]
safeFiles -> do
          let toSave :: Set FilePath
toSave = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (SimpleEntry -> FilePath
seSource forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(SafeFilePath, SimpleEntry)]
safeFiles
          (Map FilePath (BlobKey, BlobId)
blobs :: 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 forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ \Map FilePath (BlobKey, BlobId)
m MetaEntry
me ->
              if MetaEntry -> FilePath
mePath MetaEntry
me forall a. Ord a => a -> Set a -> Bool
`Set.member` Set FilePath
toSave
                then do
                  ByteString
bs <- forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
sinkList
                  (BlobId
blobId, BlobKey
blobKey) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage forall a b. (a -> b) -> a -> b
$ forall env.
ByteString -> ReaderT SqlBackend (RIO env) (BlobId, BlobKey)
storeBlob ByteString
bs
                  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 forall (f :: * -> *) a. Applicative f => a -> f a
pure Map FilePath (BlobKey, BlobId)
m
          CachedTree
tree :: CachedTree <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map SafeFilePath (TreeEntry, BlobId) -> CachedTree
CachedTreeMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(SafeFilePath, SimpleEntry)]
safeFiles forall a b. (a -> b) -> a -> b
$ \(SafeFilePath
sfp, SimpleEntry
se) ->
            case 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 -> forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$ FilePath
"Impossible: blob not found for: " forall a. [a] -> [a] -> [a]
++ SimpleEntry -> FilePath
seSource SimpleEntry
se
              Just (BlobKey
blobKey, BlobId
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 <- forall (m :: * -> *).
MonadThrow m =>
RawPackageLocationImmutable -> Tree -> m BuildFile
findCabalOrHpackFile RawPackageLocationImmutable
rpli 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
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (SafeFilePath
fpath, BlobKey
key, TreeEntry
te)
                                                                 BFHpack te :: TreeEntry
te@(TreeEntry BlobKey
key FileType
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (SafeFilePath
hpackSafeFilePath, BlobKey
key, TreeEntry
te)
          Maybe ByteString
mbs <- forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage forall a b. (a -> b) -> a -> b
$ forall env.
HasLogFunc env =>
BlobKey -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
loadBlob BlobKey
buildFileBlobKey
          ByteString
bs <-
            case Maybe ByteString
mbs of
              Maybe ByteString
Nothing -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable
-> SafeFilePath -> BlobKey -> PantryException
TreeReferencesMissingBlob RawPackageLocationImmutable
rpli SafeFilePath
buildFilePath BlobKey
buildFileBlobKey
              Just ByteString
bs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs
          ByteString
cabalBs <- case BuildFile
buildFile of
            BFCabal SafeFilePath
_ TreeEntry
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs
            BFHpack TreeEntry
_ -> forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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) <- forall (m :: * -> *).
MonadThrow m =>
Either RawPackageLocationImmutable (Path Abs File)
-> ByteString -> m ([PWarning], GenericPackageDescription)
rawParseGPD (forall a b. a -> Either a b
Left RawPackageLocationImmutable
rpli) ByteString
cabalBs
          let ident :: PackageIdentifier
ident@(PackageIdentifier PackageName
name Version
_) = PackageDescription -> PackageIdentifier
package forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
packageDescription GenericPackageDescription
gpd
          case BuildFile
buildFile of
            BFCabal SafeFilePath
_ TreeEntry
_ -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SafeFilePath
buildFilePath forall a. Eq a => a -> a -> Bool
/= PackageName -> SafeFilePath
cabalFileName PackageName
name) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable
-> SafeFilePath -> PackageName -> PantryException
WrongCabalFileName RawPackageLocationImmutable
rpli SafeFilePath
buildFilePath PackageName
name
            BuildFile
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
          -- It's good! Store the tree, let's bounce

          (TreeId
tid, TreeKey
treeKey') <- forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage forall a b. (a -> b) -> a -> b
$ forall env.
(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
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ TreeEntry -> PackageCabal
PCCabalFile TreeEntry
buildFileEntry
                            BFHpack TreeEntry
_ -> do
                              BlobKey
cabalKey <- forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage forall a b. (a -> b) -> a -> b
$ do
                                            Key HPack
hpackId <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> TreeId -> ReaderT SqlBackend (RIO env) (Key HPack)
storeHPack RawPackageLocationImmutable
rpli TreeId
tid
                                            forall env. Key HPack -> ReaderT SqlBackend (RIO env) BlobKey
loadCabalBlobKey Key HPack
hpackId
                              Version
hpackSoftwareVersion <- 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)
                              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ PHpack -> PackageCabal
PCHpack forall a b. (a -> b) -> a -> b
$ PHpack { phOriginal :: TreeEntry
phOriginal = TreeEntry
buildFileEntry, phGenerated :: TreeEntry
phGenerated = TreeEntry
cabalTreeEntry, phVersion :: Version
phVersion = Version
hpackSoftwareVersion}
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {t}. (FilePath, t) -> Maybe (FilePath, t)
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList
  where
    prefix :: FilePath
prefix = FilePath
dir forall a. [a] -> [a] -> [a]
++ FilePath
"/"
    go :: (FilePath, t) -> Maybe (FilePath, t)
go (FilePath
x, t
y) = (, t
y) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripPrefix FilePath
prefix FilePath
x

findCabalOrHpackFile
  :: MonadThrow m
  => RawPackageLocationImmutable -- ^ for exceptions

  -> Tree
  -> m BuildFile
findCabalOrHpackFile :: forall (m :: * -> *).
MonadThrow m =>
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) 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 (forall {b}. (SafeFilePath, b) -> Bool
isCabalFile (SafeFilePath, TreeEntry)
xs)
                                              then forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ SafeFilePath -> TreeEntry -> BuildFile
BFCabal SafeFilePath
sfp TreeEntry
te
                                              else forall a. Maybe a
Nothing
                                     hpFile :: Maybe BuildFile
hpFile = if (forall {b}. (SafeFilePath, b) -> Bool
isHpackFile (SafeFilePath, TreeEntry)
xs)
                                              then forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ TreeEntry -> BuildFile
BFHpack TreeEntry
te
                                              else forall a. Maybe a
Nothing
                                 in Maybe BuildFile
cbFile forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe BuildFile
hpFile
  case forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (SafeFilePath, TreeEntry) -> Maybe BuildFile
toBuildFile forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map SafeFilePath TreeEntry
m of
    [] -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable -> PantryException
TreeWithoutCabalFile RawPackageLocationImmutable
loc
    [BuildFile
bfile] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure BuildFile
bfile
    [BuildFile]
xs -> case (forall a. (a -> Bool) -> [a] -> [a]
filter BuildFile -> Bool
isBFCabal [BuildFile]
xs) of
            [] -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable -> PantryException
TreeWithoutCabalFile RawPackageLocationImmutable
loc
            [BuildFile
bfile] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure BuildFile
bfile
            [BuildFile]
xs' -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable -> [SafeFilePath] -> PantryException
TreeWithMultipleCabalFiles RawPackageLocationImmutable
loc forall a b. (a -> b) -> a -> b
$ 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 :: forall a. [(FilePath, a)] -> [(FilePath, a)]
stripCommonPrefix [] = []
stripCommonPrefix pairs :: [(FilePath, a)]
pairs@((FilePath
firstFP, a
_):[(FilePath, a)]
_) = forall a. a -> Maybe a -> a
fromMaybe [(FilePath, a)]
pairs forall a b. (a -> b) -> a -> b
$ do
  let firstDir :: FilePath
firstDir = forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'/') FilePath
firstFP
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ 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) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripPrefix (FilePath
firstDir forall a. [a] -> [a] -> [a]
++ FilePath
"/") FilePath
fp
  forall a. [(FilePath, a)] -> [(FilePath, a)]
stripCommonPrefix forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse 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 :: forall a. Text -> [(FilePath, a)] -> [(Text, a)]
takeSubdir Text
subdir = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a b. (a -> b) -> a -> b
$ \(FilePath
fp, a
a) -> do
  [Text]
stripped <- forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripPrefix [Text]
subdirs forall a b. (a -> b) -> a -> b
$ Text -> [Text]
splitDirs forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
fp
  forall a. a -> Maybe a
Just (Text -> [Text] -> Text
T.intercalate Text
"/" [Text]
stripped, a
a)
  where
    splitDirs :: Text -> [Text]
splitDirs = forall a. (a -> Bool) -> [a] -> [a]
List.dropWhile (forall a. Eq a => a -> a -> Bool
== Text
".") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= 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