{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}

-- | Logic for loading up trees from HTTPS archives.

module Pantry.Archive
  ( getArchivePackage
  , getArchive
  , getArchiveKey
  , fetchArchivesRaw
  , fetchArchives
  , findCabalOrHpackFile
  ) where

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

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
-> ([Char] -> SHA256 -> FileSize -> RIO env a) -> RIO env a
withArchiveLoc RawArchive
archive forall a b. (a -> b) -> a -> b
$ \[Char]
fp SHA256
sha FileSize
size -> do
        (Package
pa, CachedTree
tree) <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> RawArchive -> [Char] -> RIO env (Package, CachedTree)
parseArchive RawPackageLocationImmutable
rpli RawArchive
archive [Char]
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
-> ([Char] -> SHA256 -> FileSize -> RIO env a) -> RIO env a
withArchiveLoc (RawArchive (ALFilePath ResolvedPath File
resolved) Maybe SHA256
msha Maybe FileSize
msize Text
_subdir) [Char] -> 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 :: [Char]
fp = forall b t. Path b t -> [Char]
toFilePath Path Abs File
abs'
  (SHA256
sha, FileSize
size) <- forall (m :: * -> *) a.
MonadUnliftIO m =>
[Char] -> IOMode -> (Handle -> m a) -> m a
withBinaryFile [Char]
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)
  [Char] -> SHA256 -> FileSize -> RIO env a
f [Char]
fp SHA256
sha FileSize
size
withArchiveLoc (RawArchive (ALUrl Text
url) Maybe SHA256
msha Maybe FileSize
msize Text
_subdir) [Char] -> SHA256 -> FileSize -> RIO env a
f =
  forall (m :: * -> *) a.
MonadUnliftIO m =>
[Char] -> ([Char] -> Handle -> m a) -> m a
withSystemTempFile [Char]
"archive" forall a b. (a -> b) -> a -> b
$ \[Char]
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
    [Char] -> SHA256 -> FileSize -> RIO env a
f [Char]
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 -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [METype] -> ShowS
$cshowList :: [METype] -> ShowS
show :: METype -> [Char]
$cshow :: METype -> [Char]
showsPrec :: Int -> METype -> ShowS
$cshowsPrec :: Int -> METype -> ShowS
Show

data MetaEntry = MetaEntry
  { MetaEntry -> [Char]
mePath :: !FilePath
  , MetaEntry -> METype
meType :: !METype
  }
  deriving Int -> MetaEntry -> ShowS
[MetaEntry] -> ShowS
MetaEntry -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [MetaEntry] -> ShowS
$cshowList :: [MetaEntry] -> ShowS
show :: MetaEntry -> [Char]
$cshow :: MetaEntry -> [Char]
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
-> [Char]
-> ArchiveType
-> a
-> (a -> MetaEntry -> ConduitT ByteString Void (RIO env) a)
-> RIO env a
foldArchive ArchiveLocation
loc [Char]
fp ArchiveType
ATTarGz a
accum a -> MetaEntry -> ConduitT ByteString Void (RIO env) a
f =
  forall (m :: * -> *) (n :: * -> *) i a.
(MonadUnliftIO m, MonadIO n) =>
[Char] -> (ConduitM i ByteString n () -> m a) -> m a
withSourceFile [Char]
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 [Char]
fp ArchiveType
ATTar a
accum a -> MetaEntry -> ConduitT ByteString Void (RIO env) a
f =
  forall (m :: * -> *) (n :: * -> *) i a.
(MonadUnliftIO m, MonadIO n) =>
[Char] -> (ConduitM i ByteString n () -> m a) -> m a
withSourceFile [Char]
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 [Char]
fp ArchiveType
ATZip a
accum0 a -> MetaEntry -> ConduitT ByteString Void (RIO env) a
f = forall (m :: * -> *) a.
MonadUnliftIO m =>
[Char] -> IOMode -> (Handle -> m a) -> m a
withBinaryFile [Char]
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 normalizedRelPath :: [Char]
normalizedRelPath = ShowS
removeInitialDotSlash forall a b. (a -> b) -> a -> b
$ Entry -> [Char]
Zip.eRelativePath Entry
entry
            me :: MetaEntry
me = [Char] -> METype -> MetaEntry
MetaEntry [Char]
normalizedRelPath 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 -> [Char] -> Mismatch Word32 -> PantryException
CRC32Mismatch ArchiveLocation
loc (Entry -> [Char]
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 -> [Char]
Zip.eRelativePath Entry
entry of
          Char
'/':[Char]
_ -> Bool
True
          [Char]
_ -> 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
$ forall (m :: * -> *). MonadIO m => FileInfo -> m (Maybe MetaEntry)
toME forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> 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 -> [Char] -> FileType -> PantryException
InvalidTarFileType ArchiveLocation
loc (FileInfo -> [Char]
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
$ [Char] -> METype
METLink forall a b. (a -> b) -> a -> b
$ Text -> [Char]
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 :: [Char]
mePath = ShowS
removeInitialDotSlash forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileInfo -> [Char]
Tar.getFileInfoPath forall a b. (a -> b) -> a -> b
$ 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 -> [Char]
seSource :: !FilePath
  , SimpleEntry -> FileType
seType :: !FileType
  }
  deriving Int -> SimpleEntry -> ShowS
[SimpleEntry] -> ShowS
SimpleEntry -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [SimpleEntry] -> ShowS
$cshowList :: [SimpleEntry] -> ShowS
show :: SimpleEntry -> [Char]
$cshow :: SimpleEntry -> [Char]
showsPrec :: Int -> SimpleEntry -> ShowS
$cshowsPrec :: Int -> SimpleEntry -> ShowS
Show

removeInitialDotSlash :: FilePath -> FilePath
removeInitialDotSlash :: ShowS
removeInitialDotSlash [Char]
filename =
  forall a. a -> Maybe a -> a
fromMaybe [Char]
filename forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripPrefix [Char]
"./" [Char]
filename

-- | 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 ::
     forall env. (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 -> [Char] -> RIO env (Package, CachedTree)
parseArchive RawPackageLocationImmutable
rpli RawArchive
archive [Char]
fp = do
  let loc :: ArchiveLocation
loc = RawArchive -> ArchiveLocation
raLocation RawArchive
archive
      archiveTypes :: [ArchiveType]
      archiveTypes :: [ArchiveType]
archiveTypes = [forall a. Bounded a => a
minBound .. forall a. Bounded a => a
maxBound]
      getFiles :: [ArchiveType] -> RIO env (ArchiveType, Map FilePath MetaEntry)
      getFiles :: [ArchiveType] -> RIO env (ArchiveType, Map [Char] 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
$
          -- foldArchive normalises filepaths in archives that begin with ./

          forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ArchiveLocation
-> [Char]
-> ArchiveType
-> a
-> (a -> MetaEntry -> ConduitT ByteString Void (RIO env) a)
-> RIO env a
foldArchive ArchiveLocation
loc [Char]
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 [Char] 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 -> [Char]
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, Map [Char] MetaEntry
files) <- [ArchiveType] -> RIO env (ArchiveType, Map [Char] MetaEntry)
getFiles [ArchiveType]
archiveTypes
  let toSimple :: FilePath -> MetaEntry -> Either String (Map FilePath SimpleEntry)
      toSimple :: [Char] -> MetaEntry -> Either [Char] (Map [Char] SimpleEntry)
toSimple [Char]
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 [Char]
key forall a b. (a -> b) -> a -> b
$ [Char] -> FileType -> SimpleEntry
SimpleEntry (MetaEntry -> [Char]
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 [Char]
key forall a b. (a -> b) -> a -> b
$ [Char] -> FileType -> SimpleEntry
SimpleEntry (MetaEntry -> [Char]
mePath MetaEntry
me) FileType
FTExecutable
          METLink [Char]
relDest -> do
            case [Char]
relDest of
              Char
'/':[Char]
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                         [ [Char]
"File located at "
                         , forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ MetaEntry -> [Char]
mePath MetaEntry
me
                         , [Char]
" is a symbolic link to absolute path "
                         , [Char]
relDest
                         ]
              [Char]
_ -> forall a b. b -> Either a b
Right ()
            [Char]
dest0 <-
              case [Char] -> [Char] -> Either [Char] [Char]
makeTarRelative (MetaEntry -> [Char]
mePath MetaEntry
me) [Char]
relDest of
                Left [Char]
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
                  [ [Char]
"Error resolving relative path "
                  , [Char]
relDest
                  , [Char]
" from symlink at "
                  , MetaEntry -> [Char]
mePath MetaEntry
me
                  , [Char]
": "
                  , [Char]
e
                  ]
                Right [Char]
x -> forall a b. b -> Either a b
Right [Char]
x
            [Char]
dest <-
              case [Char] -> Either [Char] [Char]
normalizeParents [Char]
dest0 of
                Left [Char]
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
                  [ [Char]
"Invalid symbolic link from "
                  , MetaEntry -> [Char]
mePath MetaEntry
me
                  , [Char]
" to "
                  , [Char]
relDest
                  , [Char]
", tried parsing "
                  , [Char]
dest0
                  , [Char]
": "
                  , [Char]
e
                  ]
                Right [Char]
x -> forall a b. b -> Either a b
Right [Char]
x
            -- Check if it's a symlink to a file

            case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
dest Map [Char] MetaEntry
files of
              Maybe MetaEntry
Nothing ->
                -- Check if it's a symlink to a directory

                case [Char] -> Map [Char] MetaEntry -> [([Char], MetaEntry)]
findWithPrefix [Char]
dest Map [Char] MetaEntry
files of
                  [] -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
                             [Char]
"Symbolic link dest not found from "
                          forall a. [a] -> [a] -> [a]
++ MetaEntry -> [Char]
mePath MetaEntry
me
                          forall a. [a] -> [a] -> [a]
++ [Char]
" to "
                          forall a. [a] -> [a] -> [a]
++ [Char]
relDest
                          forall a. [a] -> [a] -> [a]
++ [Char]
", looking for "
                          forall a. [a] -> [a] -> [a]
++ [Char]
dest
                          forall a. [a] -> [a] -> [a]
++ [Char]
".\n"
                          forall a. [a] -> [a] -> [a]
++ [Char]
"This may indicate that the source is a git \
                             \archive which uses git-annex.\n"
                          forall a. [a] -> [a] -> [a]
++ [Char]
"See https://github.com/commercialhaskell/stack/issues/4579 \
                             \for further information."
                  [([Char], 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 [([Char], MetaEntry)]
pairs forall a b. (a -> b) -> a -> b
$ \([Char]
suffix, MetaEntry
me') ->
                      [Char] -> MetaEntry -> Either [Char] (Map [Char] SimpleEntry)
toSimple ([Char]
key forall a. [a] -> [a] -> [a]
++ Char
'/' forall a. a -> [a] -> [a]
: [Char]
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 [Char]
key forall a b. (a -> b) -> a -> b
$ [Char] -> FileType -> SimpleEntry
SimpleEntry [Char]
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 [Char]
key forall a b. (a -> b) -> a -> b
$ [Char] -> FileType -> SimpleEntry
SimpleEntry [Char]
dest FileType
FTExecutable
                  METLink [Char]
_ ->
                    forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
                         [Char]
"Symbolic link dest cannot be a symbolic link, from "
                      forall a. [a] -> [a] -> [a]
++ MetaEntry -> [Char]
mePath MetaEntry
me
                      forall a. [a] -> [a] -> [a]
++ [Char]
" to "
                      forall a. [a] -> [a] -> [a]
++ [Char]
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 [Char] -> MetaEntry -> Either [Char] (Map [Char] SimpleEntry)
toSimple Map [Char] MetaEntry
files of
    Left [Char]
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
$ [Char] -> Text
T.pack [Char]
e
    Right Map [Char] SimpleEntry
files1 -> do
      let files2 :: [([Char], SimpleEntry)]
files2 = forall a. [([Char], a)] -> [([Char], a)]
stripCommonPrefix forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map [Char] SimpleEntry
files1
          files3 :: [(Text, SimpleEntry)]
files3 = forall a. Text -> [([Char], a)] -> [(Text, a)]
takeSubdir (RawArchive -> Text
raSubdir RawArchive
archive) [([Char], SimpleEntry)]
files2
          toSafe :: (Text, b) -> Either [Char] (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
$ [Char]
"Not a safe file path: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
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 [Char] (SafeFilePath, b)
toSafe [(Text, SimpleEntry)]
files3 of
        Left [Char]
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
$ [Char] -> Text
T.pack [Char]
e
        Right [(SafeFilePath, SimpleEntry)]
safeFiles -> do
          let toSave :: Set [Char]
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 -> [Char]
seSource forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(SafeFilePath, SimpleEntry)]
safeFiles
          (Map [Char] (BlobKey, BlobId)
blobs :: Map FilePath (BlobKey, BlobId)) <-
            forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ArchiveLocation
-> [Char]
-> ArchiveType
-> a
-> (a -> MetaEntry -> ConduitT ByteString Void (RIO env) a)
-> RIO env a
foldArchive ArchiveLocation
loc [Char]
fp ArchiveType
at forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ \Map [Char] (BlobKey, BlobId)
m MetaEntry
me ->
              if MetaEntry -> [Char]
mePath MetaEntry
me forall a. Ord a => a -> Set a -> Bool
`Set.member` Set [Char]
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 -> [Char]
mePath MetaEntry
me) (BlobKey
blobKey, BlobId
blobId) Map [Char] (BlobKey, BlobId)
m
                else forall (f :: * -> *) a. Applicative f => a -> f a
pure Map [Char] (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 (ShowS
removeInitialDotSlash forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleEntry -> [Char]
seSource forall a b. (a -> b) -> a -> b
$ SimpleEntry
se) Map [Char] (BlobKey, BlobId)
blobs of
                Maybe (BlobKey, BlobId)
Nothing ->
                  forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Impossible: blob not found for: " forall a. [a] -> [a] -> [a]
++ SimpleEntry -> [Char]
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 (f :: * -> *) a. Applicative f => a -> f a
pure ()
          -- 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 :: [Char] -> Map [Char] MetaEntry -> [([Char], MetaEntry)]
findWithPrefix [Char]
dir = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {t}. ([Char], t) -> Maybe ([Char], t)
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList
 where
  prefix :: [Char]
prefix = [Char]
dir forall a. [a] -> [a] -> [a]
++ [Char]
"/"
  go :: ([Char], t) -> Maybe ([Char], t)
go ([Char]
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 [Char]
prefix [Char]
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 [Char] -> Text
T.pack [Char]
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. [([Char], a)] -> [([Char], a)]
stripCommonPrefix [] = []
stripCommonPrefix pairs :: [([Char], a)]
pairs@(([Char]
firstFP, a
_):[([Char], a)]
_) = forall a. a -> Maybe a -> a
fromMaybe [([Char], a)]
pairs forall a b. (a -> b) -> a -> b
$ do
  let firstDir :: [Char]
firstDir = forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'/') [Char]
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 [Char]
firstDir
  let strip :: ([Char], t) -> Maybe ([Char], t)
strip ([Char]
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 ([Char]
firstDir forall a. [a] -> [a] -> [a]
++ [Char]
"/") [Char]
fp
  forall a. [([Char], a)] -> [([Char], 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}. ([Char], t) -> Maybe ([Char], t)
strip [([Char], 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 -> [([Char], a)] -> [(Text, a)]
takeSubdir Text
subdir = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a b. (a -> b) -> a -> b
$ \([Char]
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
$ [Char] -> Text
T.pack [Char]
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