{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Pantry.Archive
( getArchivePackage
, getArchive
, getArchiveKey
, fetchArchivesRaw
, fetchArchives
, findCabalOrHpackFile
) where
import RIO
import qualified Pantry.SHA256 as SHA256
import Pantry.Storage hiding (Tree, TreeEntry)
import Pantry.Tree
import Pantry.Types
import RIO.Process
import Pantry.Internal (normalizeParents, makeTarRelative)
import qualified RIO.Text as T
import qualified RIO.Text.Partial as T
import qualified RIO.List as List
import qualified RIO.ByteString.Lazy as BL
import qualified RIO.Map as Map
import qualified RIO.Set as Set
import qualified Hpack.Config as Hpack
import Pantry.HPack (hpackVersion)
import Data.Bits ((.&.), shiftR)
import Path (toFilePath)
import qualified Codec.Archive.Zip as Zip
import qualified Data.Digest.CRC32 as CRC32
import Distribution.PackageDescription (packageDescription, package)
import Conduit
import Data.Conduit.Zlib (ungzip)
import qualified Data.Conduit.Tar as Tar
import Pantry.HTTP
fetchArchivesRaw
:: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> [(RawArchive, RawPackageMetadata)]
-> RIO env ()
fetchArchivesRaw :: [(RawArchive, RawPackageMetadata)] -> RIO env ()
fetchArchivesRaw pairs :: [(RawArchive, RawPackageMetadata)]
pairs =
[(RawArchive, RawPackageMetadata)]
-> ((RawArchive, RawPackageMetadata)
-> RIO env (SHA256, FileSize, Package))
-> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(RawArchive, RawPackageMetadata)]
pairs (((RawArchive, RawPackageMetadata)
-> RIO env (SHA256, FileSize, Package))
-> RIO env ())
-> ((RawArchive, RawPackageMetadata)
-> RIO env (SHA256, FileSize, Package))
-> RIO env ()
forall a b. (a -> b) -> a -> b
$ \(ra :: RawArchive
ra, rpm :: RawPackageMetadata
rpm) ->
RawPackageLocationImmutable
-> RawArchive
-> RawPackageMetadata
-> RIO env (SHA256, FileSize, Package)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env,
HasCallStack) =>
RawPackageLocationImmutable
-> RawArchive
-> RawPackageMetadata
-> RIO env (SHA256, FileSize, Package)
getArchive (RawArchive -> RawPackageMetadata -> RawPackageLocationImmutable
RPLIArchive RawArchive
ra RawPackageMetadata
rpm) RawArchive
ra RawPackageMetadata
rpm
fetchArchives
:: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> [(Archive, PackageMetadata)]
-> RIO env ()
fetchArchives :: [(Archive, PackageMetadata)] -> RIO env ()
fetchArchives pairs :: [(Archive, PackageMetadata)]
pairs =
[(RawArchive, RawPackageMetadata)] -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
[(RawArchive, RawPackageMetadata)] -> RIO env ()
fetchArchivesRaw [(Archive -> RawArchive
toRawArchive Archive
a, PackageMetadata -> RawPackageMetadata
toRawPM PackageMetadata
pm) | (a :: Archive
a, pm :: PackageMetadata
pm) <- [(Archive, PackageMetadata)]
pairs]
getArchiveKey
:: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> RawPackageLocationImmutable
-> RawArchive
-> RawPackageMetadata
-> RIO env TreeKey
getArchiveKey :: RawPackageLocationImmutable
-> RawArchive -> RawPackageMetadata -> RIO env TreeKey
getArchiveKey rpli :: RawPackageLocationImmutable
rpli archive :: RawArchive
archive rpm :: RawPackageMetadata
rpm =
Package -> TreeKey
packageTreeKey (Package -> TreeKey) -> RIO env Package -> RIO env TreeKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawPackageLocationImmutable
-> RawArchive -> RawPackageMetadata -> RIO env Package
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env,
HasCallStack) =>
RawPackageLocationImmutable
-> RawArchive -> RawPackageMetadata -> RIO env Package
getArchivePackage RawPackageLocationImmutable
rpli RawArchive
archive RawPackageMetadata
rpm
thd3 :: (a, b, c) -> c
thd3 :: (a, b, c) -> c
thd3 (_, _, z :: c
z) = c
z
getArchivePackage
:: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env, HasCallStack)
=> RawPackageLocationImmutable
-> RawArchive
-> RawPackageMetadata
-> RIO env Package
getArchivePackage :: RawPackageLocationImmutable
-> RawArchive -> RawPackageMetadata -> RIO env Package
getArchivePackage rpli :: RawPackageLocationImmutable
rpli archive :: RawArchive
archive rpm :: RawPackageMetadata
rpm = (SHA256, FileSize, Package) -> Package
forall a b c. (a, b, c) -> c
thd3 ((SHA256, FileSize, Package) -> Package)
-> RIO env (SHA256, FileSize, Package) -> RIO env Package
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawPackageLocationImmutable
-> RawArchive
-> RawPackageMetadata
-> RIO env (SHA256, FileSize, Package)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env,
HasCallStack) =>
RawPackageLocationImmutable
-> RawArchive
-> RawPackageMetadata
-> RIO env (SHA256, FileSize, Package)
getArchive RawPackageLocationImmutable
rpli RawArchive
archive RawPackageMetadata
rpm
getArchive
:: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env, HasCallStack)
=> RawPackageLocationImmutable
-> RawArchive
-> RawPackageMetadata
-> RIO env (SHA256, FileSize, Package)
getArchive :: RawPackageLocationImmutable
-> RawArchive
-> RawPackageMetadata
-> RIO env (SHA256, FileSize, Package)
getArchive rpli :: RawPackageLocationImmutable
rpli archive :: RawArchive
archive rpm :: RawPackageMetadata
rpm = do
Maybe (SHA256, FileSize, Package)
mcached <- RawPackageLocationImmutable
-> RawArchive -> RIO env (Maybe (SHA256, FileSize, Package))
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> RawArchive -> RIO env (Maybe (SHA256, FileSize, Package))
loadCache RawPackageLocationImmutable
rpli RawArchive
archive
cached :: (SHA256, FileSize, Package)
cached@(_, _, pa :: Package
pa) <-
case Maybe (SHA256, FileSize, Package)
mcached of
Just stored :: (SHA256, FileSize, Package)
stored -> (SHA256, FileSize, Package) -> RIO env (SHA256, FileSize, Package)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SHA256, FileSize, Package)
stored
Nothing -> RawArchive
-> (FilePath
-> SHA256 -> FileSize -> RIO env (SHA256, FileSize, Package))
-> RIO env (SHA256, FileSize, Package)
forall env a.
HasLogFunc env =>
RawArchive
-> (FilePath -> SHA256 -> FileSize -> RIO env a) -> RIO env a
withArchiveLoc RawArchive
archive ((FilePath
-> SHA256 -> FileSize -> RIO env (SHA256, FileSize, Package))
-> RIO env (SHA256, FileSize, Package))
-> (FilePath
-> SHA256 -> FileSize -> RIO env (SHA256, FileSize, Package))
-> RIO env (SHA256, FileSize, Package)
forall a b. (a -> b) -> a -> b
$ \fp :: FilePath
fp sha :: SHA256
sha size :: FileSize
size -> do
Package
pa <- RawPackageLocationImmutable
-> RawArchive -> FilePath -> RIO env Package
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> RawArchive -> FilePath -> RIO env Package
parseArchive RawPackageLocationImmutable
rpli RawArchive
archive FilePath
fp
RawArchive -> SHA256 -> FileSize -> Package -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawArchive -> SHA256 -> FileSize -> Package -> RIO env ()
storeCache RawArchive
archive SHA256
sha FileSize
size Package
pa
(SHA256, FileSize, Package) -> RIO env (SHA256, FileSize, Package)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SHA256
sha, FileSize
size, Package
pa)
(PantryException -> RIO env (SHA256, FileSize, Package))
-> (Package -> RIO env (SHA256, FileSize, Package))
-> Either PantryException Package
-> RIO env (SHA256, FileSize, Package)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either PantryException -> RIO env (SHA256, FileSize, Package)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (\_ -> (SHA256, FileSize, Package) -> RIO env (SHA256, FileSize, Package)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SHA256, FileSize, Package)
cached) (Either PantryException Package
-> RIO env (SHA256, FileSize, Package))
-> Either PantryException Package
-> RIO env (SHA256, FileSize, Package)
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable
-> RawPackageMetadata -> Package -> Either PantryException Package
checkPackageMetadata RawPackageLocationImmutable
rpli RawPackageMetadata
rpm Package
pa
storeCache
:: forall env. (HasPantryConfig env, HasLogFunc env)
=> RawArchive
-> SHA256
-> FileSize
-> Package
-> RIO env ()
storeCache :: RawArchive -> SHA256 -> FileSize -> Package -> RIO env ()
storeCache archive :: RawArchive
archive sha :: SHA256
sha size :: FileSize
size pa :: Package
pa =
case RawArchive -> ArchiveLocation
raLocation RawArchive
archive of
ALUrl url :: Text
url -> ReaderT SqlBackend (RIO env) () -> RIO env ()
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) () -> RIO env ())
-> ReaderT SqlBackend (RIO env) () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Text
-> Text
-> SHA256
-> FileSize
-> TreeKey
-> ReaderT SqlBackend (RIO env) ()
forall env.
Text
-> Text
-> SHA256
-> FileSize
-> TreeKey
-> ReaderT SqlBackend (RIO env) ()
storeArchiveCache Text
url (RawArchive -> Text
raSubdir RawArchive
archive) SHA256
sha FileSize
size (Package -> TreeKey
packageTreeKey Package
pa)
ALFilePath _ -> () -> RIO env ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
loadCache
:: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> RawPackageLocationImmutable
-> RawArchive
-> RIO env (Maybe (SHA256, FileSize, Package))
loadCache :: RawPackageLocationImmutable
-> RawArchive -> RIO env (Maybe (SHA256, FileSize, Package))
loadCache rpli :: RawPackageLocationImmutable
rpli archive :: RawArchive
archive =
case ArchiveLocation
loc of
ALFilePath _ -> Maybe (SHA256, FileSize, Package)
-> RIO env (Maybe (SHA256, FileSize, Package))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (SHA256, FileSize, Package)
forall a. Maybe a
Nothing
ALUrl url :: Text
url -> ReaderT SqlBackend (RIO env) [(SHA256, FileSize, TreeId)]
-> RIO env [(SHA256, FileSize, TreeId)]
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (Text
-> Text
-> ReaderT SqlBackend (RIO env) [(SHA256, FileSize, TreeId)]
forall env.
Text
-> Text
-> ReaderT SqlBackend (RIO env) [(SHA256, FileSize, TreeId)]
loadArchiveCache Text
url (RawArchive -> Text
raSubdir RawArchive
archive)) RIO env [(SHA256, FileSize, TreeId)]
-> ([(SHA256, FileSize, TreeId)]
-> RIO env (Maybe (SHA256, FileSize, Package)))
-> RIO env (Maybe (SHA256, FileSize, Package))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [(SHA256, FileSize, TreeId)]
-> RIO env (Maybe (SHA256, FileSize, Package))
loop
where
loc :: ArchiveLocation
loc = RawArchive -> ArchiveLocation
raLocation RawArchive
archive
msha :: Maybe SHA256
msha = RawArchive -> Maybe SHA256
raHash RawArchive
archive
msize :: Maybe FileSize
msize = RawArchive -> Maybe FileSize
raSize RawArchive
archive
loadFromCache :: TreeId -> RIO env (Maybe Package)
loadFromCache :: TreeId -> RIO env (Maybe Package)
loadFromCache tid :: TreeId
tid = (Package -> Maybe Package)
-> RIO env Package -> RIO env (Maybe Package)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Package -> Maybe Package
forall a. a -> Maybe a
Just (RIO env Package -> RIO env (Maybe Package))
-> RIO env Package -> RIO env (Maybe Package)
forall a b. (a -> b) -> a -> b
$ ReaderT SqlBackend (RIO env) Package -> RIO env Package
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) Package -> RIO env Package)
-> ReaderT SqlBackend (RIO env) Package -> RIO env Package
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable
-> TreeId -> ReaderT SqlBackend (RIO env) Package
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> TreeId -> ReaderT SqlBackend (RIO env) Package
loadPackageById RawPackageLocationImmutable
rpli TreeId
tid
loop :: [(SHA256, FileSize, TreeId)]
-> RIO env (Maybe (SHA256, FileSize, Package))
loop [] = Maybe (SHA256, FileSize, Package)
-> RIO env (Maybe (SHA256, FileSize, Package))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (SHA256, FileSize, Package)
forall a. Maybe a
Nothing
loop ((sha :: SHA256
sha, size :: FileSize
size, tid :: TreeId
tid):rest :: [(SHA256, FileSize, TreeId)]
rest) =
case Maybe SHA256
msha of
Nothing -> do
case Maybe FileSize
msize of
Just size' :: FileSize
size' | FileSize
size FileSize -> FileSize -> Bool
forall a. Eq a => a -> a -> Bool
/= FileSize
size' -> [(SHA256, FileSize, TreeId)]
-> RIO env (Maybe (SHA256, FileSize, Package))
loop [(SHA256, FileSize, TreeId)]
rest
_ -> do
case ArchiveLocation
loc of
ALUrl url :: Text
url -> do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ "Using archive from " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
url Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> " without a specified cryptographic hash"
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ "Cached hash is " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> SHA256 -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display SHA256
sha Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> ", file size " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> FileSize -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display FileSize
size
ALFilePath _ -> () -> RIO env ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(Package -> (SHA256, FileSize, Package))
-> Maybe Package -> Maybe (SHA256, FileSize, Package)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SHA256
sha, FileSize
size,) (Maybe Package -> Maybe (SHA256, FileSize, Package))
-> RIO env (Maybe Package)
-> RIO env (Maybe (SHA256, FileSize, Package))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TreeId -> RIO env (Maybe Package)
loadFromCache TreeId
tid
Just sha' :: SHA256
sha'
| SHA256
sha SHA256 -> SHA256 -> Bool
forall a. Eq a => a -> a -> Bool
== SHA256
sha' ->
case Maybe FileSize
msize of
Nothing -> do
case ArchiveLocation
loc of
ALUrl url :: Text
url -> Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ "Archive from " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
url Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> " does not specify a size"
ALFilePath _ -> () -> RIO env ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(Package -> (SHA256, FileSize, Package))
-> Maybe Package -> Maybe (SHA256, FileSize, Package)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SHA256
sha, FileSize
size,) (Maybe Package -> Maybe (SHA256, FileSize, Package))
-> RIO env (Maybe Package)
-> RIO env (Maybe (SHA256, FileSize, Package))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TreeId -> RIO env (Maybe Package)
loadFromCache TreeId
tid
Just size' :: FileSize
size'
| FileSize
size FileSize -> FileSize -> Bool
forall a. Eq a => a -> a -> Bool
== FileSize
size' -> (Package -> (SHA256, FileSize, Package))
-> Maybe Package -> Maybe (SHA256, FileSize, Package)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SHA256
sha, FileSize
size,) (Maybe Package -> Maybe (SHA256, FileSize, Package))
-> RIO env (Maybe Package)
-> RIO env (Maybe (SHA256, FileSize, Package))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TreeId -> RIO env (Maybe Package)
loadFromCache TreeId
tid
| Bool
otherwise -> do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ "Archive from " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> ArchiveLocation -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display ArchiveLocation
loc Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> " has a matching hash but mismatched size"
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn "Please verify that your configuration provides the correct size"
[(SHA256, FileSize, TreeId)]
-> RIO env (Maybe (SHA256, FileSize, Package))
loop [(SHA256, FileSize, TreeId)]
rest
| Bool
otherwise -> [(SHA256, FileSize, TreeId)]
-> RIO env (Maybe (SHA256, FileSize, Package))
loop [(SHA256, FileSize, TreeId)]
rest
checkPackageMetadata
:: RawPackageLocationImmutable
-> RawPackageMetadata
-> Package
-> Either PantryException Package
checkPackageMetadata :: RawPackageLocationImmutable
-> RawPackageMetadata -> Package -> Either PantryException Package
checkPackageMetadata pl :: RawPackageLocationImmutable
pl pm :: RawPackageMetadata
pm pa :: Package
pa = do
let
err :: PantryException
err = RawPackageLocationImmutable
-> RawPackageMetadata
-> Maybe TreeKey
-> PackageIdentifier
-> PantryException
MismatchedPackageMetadata
RawPackageLocationImmutable
pl
RawPackageMetadata
pm
(TreeKey -> Maybe TreeKey
forall a. a -> Maybe a
Just (Package -> TreeKey
packageTreeKey Package
pa))
(Package -> PackageIdentifier
packageIdent Package
pa)
test :: Eq a => Maybe a -> a -> Bool
test :: Maybe a -> a -> Bool
test (Just x :: a
x) y :: a
y = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y
test Nothing _ = Bool
True
tests :: [Bool]
tests =
[ Maybe TreeKey -> TreeKey -> Bool
forall a. Eq a => Maybe a -> a -> Bool
test (RawPackageMetadata -> Maybe TreeKey
rpmTreeKey RawPackageMetadata
pm) (Package -> TreeKey
packageTreeKey Package
pa)
, Maybe PackageName -> PackageName -> Bool
forall a. Eq a => Maybe a -> a -> Bool
test (RawPackageMetadata -> Maybe PackageName
rpmName RawPackageMetadata
pm) (PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> PackageIdentifier -> PackageName
forall a b. (a -> b) -> a -> b
$ Package -> PackageIdentifier
packageIdent Package
pa)
, Maybe Version -> Version -> Bool
forall a. Eq a => Maybe a -> a -> Bool
test (RawPackageMetadata -> Maybe Version
rpmVersion RawPackageMetadata
pm) (PackageIdentifier -> Version
pkgVersion (PackageIdentifier -> Version) -> PackageIdentifier -> Version
forall a b. (a -> b) -> a -> b
$ Package -> PackageIdentifier
packageIdent Package
pa)
]
in if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
tests then Package -> Either PantryException Package
forall a b. b -> Either a b
Right Package
pa else PantryException -> Either PantryException Package
forall a b. a -> Either a b
Left PantryException
err
withArchiveLoc
:: HasLogFunc env
=> RawArchive
-> (FilePath -> SHA256 -> FileSize -> RIO env a)
-> RIO env a
withArchiveLoc :: RawArchive
-> (FilePath -> SHA256 -> FileSize -> RIO env a) -> RIO env a
withArchiveLoc (RawArchive (ALFilePath resolved :: ResolvedPath File
resolved) msha :: Maybe SHA256
msha msize :: Maybe FileSize
msize _subdir :: Text
_subdir) f :: FilePath -> SHA256 -> FileSize -> RIO env a
f = do
let abs' :: Path Abs File
abs' = ResolvedPath File -> Path Abs File
forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath File
resolved
fp :: FilePath
fp = Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
abs'
(sha :: SHA256
sha, size :: FileSize
size) <- FilePath
-> IOMode
-> (Handle -> RIO env (SHA256, FileSize))
-> RIO env (SHA256, FileSize)
forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> IOMode -> (Handle -> m a) -> m a
withBinaryFile FilePath
fp IOMode
ReadMode ((Handle -> RIO env (SHA256, FileSize))
-> RIO env (SHA256, FileSize))
-> (Handle -> RIO env (SHA256, FileSize))
-> RIO env (SHA256, FileSize)
forall a b. (a -> b) -> a -> b
$ \h :: Handle
h -> do
FileSize
size <- Word -> FileSize
FileSize (Word -> FileSize) -> (Integer -> Word) -> Integer -> FileSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> FileSize) -> RIO env Integer -> RIO env FileSize
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> RIO env Integer
forall (m :: * -> *). MonadIO m => Handle -> m Integer
hFileSize Handle
h
Maybe FileSize -> (FileSize -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe FileSize
msize ((FileSize -> RIO env ()) -> RIO env ())
-> (FileSize -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \size' :: FileSize
size' -> Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FileSize
size FileSize -> FileSize -> Bool
forall a. Eq a => a -> a -> Bool
/= FileSize
size') (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ PantryException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env ()) -> PantryException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Mismatch FileSize -> PantryException
LocalInvalidSize Path Abs File
abs' $WMismatch :: forall a. a -> a -> Mismatch a
Mismatch
{ mismatchExpected :: FileSize
mismatchExpected = FileSize
size'
, mismatchActual :: FileSize
mismatchActual = FileSize
size
}
SHA256
sha <- ConduitT () Void (RIO env) SHA256 -> RIO env SHA256
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (Handle -> ConduitT () ByteString (RIO env) ()
forall (m :: * -> *) i.
MonadIO m =>
Handle -> ConduitT i ByteString m ()
sourceHandle Handle
h ConduitT () ByteString (RIO env) ()
-> ConduitM ByteString Void (RIO env) SHA256
-> ConduitT () Void (RIO env) SHA256
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM ByteString Void (RIO env) SHA256
forall (m :: * -> *) o. Monad m => ConduitT ByteString o m SHA256
SHA256.sinkHash)
Maybe SHA256 -> (SHA256 -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe SHA256
msha ((SHA256 -> RIO env ()) -> RIO env ())
-> (SHA256 -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \sha' :: SHA256
sha' -> Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SHA256
sha SHA256 -> SHA256 -> Bool
forall a. Eq a => a -> a -> Bool
/= SHA256
sha') (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ PantryException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env ()) -> PantryException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Mismatch SHA256 -> PantryException
LocalInvalidSHA256 Path Abs File
abs' $WMismatch :: forall a. a -> a -> Mismatch a
Mismatch
{ mismatchExpected :: SHA256
mismatchExpected = SHA256
sha'
, mismatchActual :: SHA256
mismatchActual = SHA256
sha
}
(SHA256, FileSize) -> RIO env (SHA256, FileSize)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SHA256
sha, FileSize
size)
FilePath -> SHA256 -> FileSize -> RIO env a
f FilePath
fp SHA256
sha FileSize
size
withArchiveLoc (RawArchive (ALUrl url :: Text
url) msha :: Maybe SHA256
msha msize :: Maybe FileSize
msize _subdir :: Text
_subdir) f :: FilePath -> SHA256 -> FileSize -> RIO env a
f =
FilePath -> (FilePath -> Handle -> RIO env a) -> RIO env a
forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> (FilePath -> Handle -> m a) -> m a
withSystemTempFile "archive" ((FilePath -> Handle -> RIO env a) -> RIO env a)
-> (FilePath -> Handle -> RIO env a) -> RIO env a
forall a b. (a -> b) -> a -> b
$ \fp :: FilePath
fp hout :: Handle
hout -> do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ "Downloading archive from " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
url
(sha :: SHA256
sha, size :: FileSize
size, ()) <- Text
-> Maybe SHA256
-> Maybe FileSize
-> ConduitT ByteString Void (RIO env) ()
-> RIO env (SHA256, FileSize, ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
Text
-> Maybe SHA256
-> Maybe FileSize
-> ConduitT ByteString Void m a
-> m (SHA256, FileSize, a)
httpSinkChecked Text
url Maybe SHA256
msha Maybe FileSize
msize (Handle -> ConduitT ByteString Void (RIO env) ()
forall (m :: * -> *) o.
MonadIO m =>
Handle -> ConduitT ByteString o m ()
sinkHandle Handle
hout)
Handle -> RIO env ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hClose Handle
hout
FilePath -> SHA256 -> FileSize -> RIO env a
f FilePath
fp SHA256
sha FileSize
size
data ArchiveType = ATTarGz | ATTar | ATZip
deriving (Int -> ArchiveType
ArchiveType -> Int
ArchiveType -> [ArchiveType]
ArchiveType -> ArchiveType
ArchiveType -> ArchiveType -> [ArchiveType]
ArchiveType -> ArchiveType -> ArchiveType -> [ArchiveType]
(ArchiveType -> ArchiveType)
-> (ArchiveType -> ArchiveType)
-> (Int -> ArchiveType)
-> (ArchiveType -> Int)
-> (ArchiveType -> [ArchiveType])
-> (ArchiveType -> ArchiveType -> [ArchiveType])
-> (ArchiveType -> ArchiveType -> [ArchiveType])
-> (ArchiveType -> ArchiveType -> ArchiveType -> [ArchiveType])
-> Enum ArchiveType
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: ArchiveType -> ArchiveType -> ArchiveType -> [ArchiveType]
$cenumFromThenTo :: ArchiveType -> ArchiveType -> ArchiveType -> [ArchiveType]
enumFromTo :: ArchiveType -> ArchiveType -> [ArchiveType]
$cenumFromTo :: ArchiveType -> ArchiveType -> [ArchiveType]
enumFromThen :: ArchiveType -> ArchiveType -> [ArchiveType]
$cenumFromThen :: ArchiveType -> ArchiveType -> [ArchiveType]
enumFrom :: ArchiveType -> [ArchiveType]
$cenumFrom :: ArchiveType -> [ArchiveType]
fromEnum :: ArchiveType -> Int
$cfromEnum :: ArchiveType -> Int
toEnum :: Int -> ArchiveType
$ctoEnum :: Int -> ArchiveType
pred :: ArchiveType -> ArchiveType
$cpred :: ArchiveType -> ArchiveType
succ :: ArchiveType -> ArchiveType
$csucc :: ArchiveType -> ArchiveType
Enum, ArchiveType
ArchiveType -> ArchiveType -> Bounded ArchiveType
forall a. a -> a -> Bounded a
maxBound :: ArchiveType
$cmaxBound :: ArchiveType
minBound :: ArchiveType
$cminBound :: ArchiveType
Bounded)
instance Display ArchiveType where
display :: ArchiveType -> Utf8Builder
display ATTarGz = "GZIP-ed tar file"
display ATTar = "Uncompressed tar file"
display ATZip = "Zip file"
data METype
= METNormal
| METExecutable
| METLink !FilePath
deriving Int -> METype -> ShowS
[METype] -> ShowS
METype -> FilePath
(Int -> METype -> ShowS)
-> (METype -> FilePath) -> ([METype] -> ShowS) -> Show METype
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [METype] -> ShowS
$cshowList :: [METype] -> ShowS
show :: METype -> FilePath
$cshow :: METype -> FilePath
showsPrec :: Int -> METype -> ShowS
$cshowsPrec :: Int -> METype -> ShowS
Show
data MetaEntry = MetaEntry
{ MetaEntry -> FilePath
mePath :: !FilePath
, MetaEntry -> METype
meType :: !METype
}
deriving Int -> MetaEntry -> ShowS
[MetaEntry] -> ShowS
MetaEntry -> FilePath
(Int -> MetaEntry -> ShowS)
-> (MetaEntry -> FilePath)
-> ([MetaEntry] -> ShowS)
-> Show MetaEntry
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [MetaEntry] -> ShowS
$cshowList :: [MetaEntry] -> ShowS
show :: MetaEntry -> FilePath
$cshow :: MetaEntry -> FilePath
showsPrec :: Int -> MetaEntry -> ShowS
$cshowsPrec :: Int -> MetaEntry -> ShowS
Show
foldArchive
:: (HasPantryConfig env, HasLogFunc env)
=> ArchiveLocation
-> FilePath
-> ArchiveType
-> a
-> (a -> MetaEntry -> ConduitT ByteString Void (RIO env) a)
-> RIO env a
foldArchive :: ArchiveLocation
-> FilePath
-> ArchiveType
-> a
-> (a -> MetaEntry -> ConduitT ByteString Void (RIO env) a)
-> RIO env a
foldArchive loc :: ArchiveLocation
loc fp :: FilePath
fp ATTarGz accum :: a
accum f :: a -> MetaEntry -> ConduitT ByteString Void (RIO env) a
f =
FilePath
-> (ConduitM () ByteString (RIO env) () -> RIO env a) -> RIO env a
forall (m :: * -> *) (n :: * -> *) i a.
(MonadUnliftIO m, MonadIO n) =>
FilePath -> (ConduitM i ByteString n () -> m a) -> m a
withSourceFile FilePath
fp ((ConduitM () ByteString (RIO env) () -> RIO env a) -> RIO env a)
-> (ConduitM () ByteString (RIO env) () -> RIO env a) -> RIO env a
forall a b. (a -> b) -> a -> b
$ \src :: ConduitM () ByteString (RIO env) ()
src -> ConduitT () Void (RIO env) a -> RIO env a
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void (RIO env) a -> RIO env a)
-> ConduitT () Void (RIO env) a -> RIO env a
forall a b. (a -> b) -> a -> b
$ ConduitM () ByteString (RIO env) ()
src ConduitM () ByteString (RIO env) ()
-> ConduitT ByteString Void (RIO env) a
-> ConduitT () Void (RIO env) a
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitT ByteString ByteString (RIO env) ()
forall (m :: * -> *).
(PrimMonad m, MonadThrow m) =>
ConduitT ByteString ByteString m ()
ungzip ConduitT ByteString ByteString (RIO env) ()
-> ConduitT ByteString Void (RIO env) a
-> ConduitT ByteString Void (RIO env) a
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ArchiveLocation
-> a
-> (a -> MetaEntry -> ConduitT ByteString Void (RIO env) a)
-> ConduitT ByteString Void (RIO env) a
forall env a o.
(HasPantryConfig env, HasLogFunc env) =>
ArchiveLocation
-> a
-> (a -> MetaEntry -> ConduitT ByteString o (RIO env) a)
-> ConduitT ByteString o (RIO env) a
foldTar ArchiveLocation
loc a
accum a -> MetaEntry -> ConduitT ByteString Void (RIO env) a
f
foldArchive loc :: ArchiveLocation
loc fp :: FilePath
fp ATTar accum :: a
accum f :: a -> MetaEntry -> ConduitT ByteString Void (RIO env) a
f =
FilePath
-> (ConduitM () ByteString (RIO env) () -> RIO env a) -> RIO env a
forall (m :: * -> *) (n :: * -> *) i a.
(MonadUnliftIO m, MonadIO n) =>
FilePath -> (ConduitM i ByteString n () -> m a) -> m a
withSourceFile FilePath
fp ((ConduitM () ByteString (RIO env) () -> RIO env a) -> RIO env a)
-> (ConduitM () ByteString (RIO env) () -> RIO env a) -> RIO env a
forall a b. (a -> b) -> a -> b
$ \src :: ConduitM () ByteString (RIO env) ()
src -> ConduitT () Void (RIO env) a -> RIO env a
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void (RIO env) a -> RIO env a)
-> ConduitT () Void (RIO env) a -> RIO env a
forall a b. (a -> b) -> a -> b
$ ConduitM () ByteString (RIO env) ()
src ConduitM () ByteString (RIO env) ()
-> ConduitT ByteString Void (RIO env) a
-> ConduitT () Void (RIO env) a
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ArchiveLocation
-> a
-> (a -> MetaEntry -> ConduitT ByteString Void (RIO env) a)
-> ConduitT ByteString Void (RIO env) a
forall env a o.
(HasPantryConfig env, HasLogFunc env) =>
ArchiveLocation
-> a
-> (a -> MetaEntry -> ConduitT ByteString o (RIO env) a)
-> ConduitT ByteString o (RIO env) a
foldTar ArchiveLocation
loc a
accum a -> MetaEntry -> ConduitT ByteString Void (RIO env) a
f
foldArchive loc :: ArchiveLocation
loc fp :: FilePath
fp ATZip accum0 :: a
accum0 f :: a -> MetaEntry -> ConduitT ByteString Void (RIO env) a
f = FilePath -> IOMode -> (Handle -> RIO env a) -> RIO env a
forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> IOMode -> (Handle -> m a) -> m a
withBinaryFile FilePath
fp IOMode
ReadMode ((Handle -> RIO env a) -> RIO env a)
-> (Handle -> RIO env a) -> RIO env a
forall a b. (a -> b) -> a -> b
$ \h :: Handle
h -> do
let go :: a -> Entry -> RIO env a
go accum :: a
accum entry :: Entry
entry = do
let me :: MetaEntry
me = FilePath -> METype -> MetaEntry
MetaEntry (Entry -> FilePath
Zip.eRelativePath Entry
entry) METype
met
met :: METype
met = METype -> Maybe METype -> METype
forall a. a -> Maybe a -> a
fromMaybe METype
METNormal (Maybe METype -> METype) -> Maybe METype -> METype
forall a b. (a -> b) -> a -> b
$ do
let modes :: Word32
modes = Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftR (Entry -> Word32
Zip.eExternalFileAttributes Entry
entry) 16
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Entry -> Word16
Zip.eVersionMadeBy Entry
entry Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. 0xFF00 Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== 0x0300
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Word32
modes Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= 0
METype -> Maybe METype
forall a. a -> Maybe a
Just (METype -> Maybe METype) -> METype -> Maybe METype
forall a b. (a -> b) -> a -> b
$
if (Word32
modes Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. 0o100) Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== 0
then METype
METNormal
else METype
METExecutable
lbs :: ByteString
lbs = Entry -> ByteString
Zip.fromEntry Entry
entry
let crcExpected :: Word32
crcExpected = Entry -> Word32
Zip.eCRC32 Entry
entry
crcActual :: Word32
crcActual = ByteString -> Word32
forall a. CRC32 a => a -> Word32
CRC32.crc32 ByteString
lbs
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word32
crcExpected Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
crcActual)
(RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ PantryException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env ()) -> PantryException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ ArchiveLocation -> FilePath -> Mismatch Word32 -> PantryException
CRC32Mismatch ArchiveLocation
loc (Entry -> FilePath
Zip.eRelativePath Entry
entry) $WMismatch :: forall a. a -> a -> Mismatch a
Mismatch
{ mismatchExpected :: Word32
mismatchExpected = Word32
crcExpected
, mismatchActual :: Word32
mismatchActual = Word32
crcActual
}
ConduitT () Void (RIO env) a -> RIO env a
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void (RIO env) a -> RIO env a)
-> ConduitT () Void (RIO env) a -> RIO env a
forall a b. (a -> b) -> a -> b
$ ByteString -> ConduitM () ByteString (RIO env) ()
forall (m :: * -> *) lazy strict i.
(Monad m, LazySequence lazy strict) =>
lazy -> ConduitT i strict m ()
sourceLazy ByteString
lbs ConduitM () ByteString (RIO env) ()
-> ConduitT ByteString Void (RIO env) a
-> ConduitT () Void (RIO env) a
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| a -> MetaEntry -> ConduitT ByteString Void (RIO env) a
f a
accum MetaEntry
me
isDir :: Entry -> Bool
isDir entry :: Entry
entry =
case ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Entry -> FilePath
Zip.eRelativePath Entry
entry of
'/':_ -> Bool
True
_ -> Bool
False
ByteString
lbs <- Handle -> RIO env ByteString
forall (m :: * -> *). MonadIO m => Handle -> m ByteString
BL.hGetContents Handle
h
(a -> Entry -> RIO env a) -> a -> [Entry] -> RIO env a
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM a -> Entry -> RIO env a
go a
accum0 ((Entry -> Bool) -> [Entry] -> [Entry]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Entry -> Bool) -> Entry -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entry -> Bool
isDir) ([Entry] -> [Entry]) -> [Entry] -> [Entry]
forall a b. (a -> b) -> a -> b
$ Archive -> [Entry]
Zip.zEntries (Archive -> [Entry]) -> Archive -> [Entry]
forall a b. (a -> b) -> a -> b
$ ByteString -> Archive
Zip.toArchive ByteString
lbs)
foldTar
:: (HasPantryConfig env, HasLogFunc env)
=> ArchiveLocation
-> a
-> (a -> MetaEntry -> ConduitT ByteString o (RIO env) a)
-> ConduitT ByteString o (RIO env) a
foldTar :: ArchiveLocation
-> a
-> (a -> MetaEntry -> ConduitT ByteString o (RIO env) a)
-> ConduitT ByteString o (RIO env) a
foldTar loc :: ArchiveLocation
loc accum0 :: a
accum0 f :: a -> MetaEntry -> ConduitT ByteString o (RIO env) a
f = do
IORef a
ref <- a -> ConduitT ByteString o (RIO env) (IORef a)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef a
accum0
(FileInfo -> ConduitM ByteString o (RIO env) ())
-> ConduitM ByteString o (RIO env) ()
forall (m :: * -> *) o.
MonadThrow m =>
(FileInfo -> ConduitM ByteString o m ())
-> ConduitM ByteString o m ()
Tar.untar ((FileInfo -> ConduitM ByteString o (RIO env) ())
-> ConduitM ByteString o (RIO env) ())
-> (FileInfo -> ConduitM ByteString o (RIO env) ())
-> ConduitM ByteString o (RIO env) ()
forall a b. (a -> b) -> a -> b
$ \fi :: FileInfo
fi -> FileInfo -> ConduitT ByteString o (RIO env) (Maybe MetaEntry)
forall (m :: * -> *). MonadIO m => FileInfo -> m (Maybe MetaEntry)
toME FileInfo
fi ConduitT ByteString o (RIO env) (Maybe MetaEntry)
-> (Maybe MetaEntry -> ConduitM ByteString o (RIO env) ())
-> ConduitM ByteString o (RIO env) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (MetaEntry -> ConduitM ByteString o (RIO env) ())
-> Maybe MetaEntry -> ConduitM ByteString o (RIO env) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\me :: MetaEntry
me -> do
a
accum <- IORef a -> ConduitT ByteString o (RIO env) a
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef a
ref
a
accum' <- a -> MetaEntry -> ConduitT ByteString o (RIO env) a
f a
accum MetaEntry
me
IORef a -> a -> ConduitM ByteString o (RIO env) ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef a
ref (a -> ConduitM ByteString o (RIO env) ())
-> a -> ConduitM ByteString o (RIO env) ()
forall a b. (a -> b) -> a -> b
$! a
accum')
IORef a -> ConduitT ByteString o (RIO env) a
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef a
ref
where
toME :: MonadIO m => Tar.FileInfo -> m (Maybe MetaEntry)
toME :: FileInfo -> m (Maybe MetaEntry)
toME fi :: FileInfo
fi = do
let exc :: PantryException
exc = ArchiveLocation -> FilePath -> FileType -> PantryException
InvalidTarFileType ArchiveLocation
loc (FileInfo -> FilePath
Tar.getFileInfoPath FileInfo
fi) (FileInfo -> FileType
Tar.fileType FileInfo
fi)
Maybe METype
mmet <-
case FileInfo -> FileType
Tar.fileType FileInfo
fi of
Tar.FTSymbolicLink bs :: ByteString
bs ->
case ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
bs of
Left _ -> PantryException -> m (Maybe METype)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO PantryException
exc
Right text :: Text
text -> Maybe METype -> m (Maybe METype)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe METype -> m (Maybe METype))
-> Maybe METype -> m (Maybe METype)
forall a b. (a -> b) -> a -> b
$ METype -> Maybe METype
forall a. a -> Maybe a
Just (METype -> Maybe METype) -> METype -> Maybe METype
forall a b. (a -> b) -> a -> b
$ FilePath -> METype
METLink (FilePath -> METype) -> FilePath -> METype
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
text
Tar.FTNormal -> Maybe METype -> m (Maybe METype)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe METype -> m (Maybe METype))
-> Maybe METype -> m (Maybe METype)
forall a b. (a -> b) -> a -> b
$ METype -> Maybe METype
forall a. a -> Maybe a
Just (METype -> Maybe METype) -> METype -> Maybe METype
forall a b. (a -> b) -> a -> b
$
if FileInfo -> FileMode
Tar.fileMode FileInfo
fi FileMode -> FileMode -> FileMode
forall a. Bits a => a -> a -> a
.&. 0o100 FileMode -> FileMode -> Bool
forall a. Eq a => a -> a -> Bool
/= 0
then METype
METExecutable
else METype
METNormal
Tar.FTDirectory -> Maybe METype -> m (Maybe METype)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe METype
forall a. Maybe a
Nothing
_ -> PantryException -> m (Maybe METype)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO PantryException
exc
Maybe MetaEntry -> m (Maybe MetaEntry)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe MetaEntry -> m (Maybe MetaEntry))
-> Maybe MetaEntry -> m (Maybe MetaEntry)
forall a b. (a -> b) -> a -> b
$
(\met :: METype
met -> $WMetaEntry :: FilePath -> METype -> MetaEntry
MetaEntry
{ mePath :: FilePath
mePath = FileInfo -> FilePath
Tar.getFileInfoPath FileInfo
fi
, meType :: METype
meType = METype
met
})
(METype -> MetaEntry) -> Maybe METype -> Maybe MetaEntry
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe METype
mmet
data SimpleEntry = SimpleEntry
{ SimpleEntry -> FilePath
seSource :: !FilePath
, SimpleEntry -> FileType
seType :: !FileType
}
deriving Int -> SimpleEntry -> ShowS
[SimpleEntry] -> ShowS
SimpleEntry -> FilePath
(Int -> SimpleEntry -> ShowS)
-> (SimpleEntry -> FilePath)
-> ([SimpleEntry] -> ShowS)
-> Show SimpleEntry
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [SimpleEntry] -> ShowS
$cshowList :: [SimpleEntry] -> ShowS
show :: SimpleEntry -> FilePath
$cshow :: SimpleEntry -> FilePath
showsPrec :: Int -> SimpleEntry -> ShowS
$cshowsPrec :: Int -> SimpleEntry -> ShowS
Show
parseArchive
:: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> RawPackageLocationImmutable
-> RawArchive
-> FilePath
-> RIO env Package
parseArchive :: RawPackageLocationImmutable
-> RawArchive -> FilePath -> RIO env Package
parseArchive rpli :: RawPackageLocationImmutable
rpli archive :: RawArchive
archive fp :: FilePath
fp = do
let loc :: ArchiveLocation
loc = RawArchive -> ArchiveLocation
raLocation RawArchive
archive
getFiles :: [ArchiveType] -> RIO env (ArchiveType, Map FilePath MetaEntry)
getFiles [] = PantryException -> RIO env (ArchiveType, Map FilePath MetaEntry)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env (ArchiveType, Map FilePath MetaEntry))
-> PantryException -> RIO env (ArchiveType, Map FilePath MetaEntry)
forall a b. (a -> b) -> a -> b
$ ArchiveLocation -> PantryException
UnknownArchiveType ArchiveLocation
loc
getFiles (at :: ArchiveType
at:ats :: [ArchiveType]
ats) = do
Either SomeException ([MetaEntry] -> [MetaEntry])
eres <- RIO env ([MetaEntry] -> [MetaEntry])
-> RIO env (Either SomeException ([MetaEntry] -> [MetaEntry]))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (RIO env ([MetaEntry] -> [MetaEntry])
-> RIO env (Either SomeException ([MetaEntry] -> [MetaEntry])))
-> RIO env ([MetaEntry] -> [MetaEntry])
-> RIO env (Either SomeException ([MetaEntry] -> [MetaEntry]))
forall a b. (a -> b) -> a -> b
$ ArchiveLocation
-> FilePath
-> ArchiveType
-> ([MetaEntry] -> [MetaEntry])
-> (([MetaEntry] -> [MetaEntry])
-> MetaEntry
-> ConduitT ByteString Void (RIO env) ([MetaEntry] -> [MetaEntry]))
-> RIO env ([MetaEntry] -> [MetaEntry])
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ArchiveLocation
-> FilePath
-> ArchiveType
-> a
-> (a -> MetaEntry -> ConduitT ByteString Void (RIO env) a)
-> RIO env a
foldArchive ArchiveLocation
loc FilePath
fp ArchiveType
at [MetaEntry] -> [MetaEntry]
forall a. a -> a
id ((([MetaEntry] -> [MetaEntry])
-> MetaEntry
-> ConduitT ByteString Void (RIO env) ([MetaEntry] -> [MetaEntry]))
-> RIO env ([MetaEntry] -> [MetaEntry]))
-> (([MetaEntry] -> [MetaEntry])
-> MetaEntry
-> ConduitT ByteString Void (RIO env) ([MetaEntry] -> [MetaEntry]))
-> RIO env ([MetaEntry] -> [MetaEntry])
forall a b. (a -> b) -> a -> b
$ \m :: [MetaEntry] -> [MetaEntry]
m me :: MetaEntry
me -> ([MetaEntry] -> [MetaEntry])
-> ConduitT ByteString Void (RIO env) ([MetaEntry] -> [MetaEntry])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([MetaEntry] -> [MetaEntry])
-> ConduitT ByteString Void (RIO env) ([MetaEntry] -> [MetaEntry]))
-> ([MetaEntry] -> [MetaEntry])
-> ConduitT ByteString Void (RIO env) ([MetaEntry] -> [MetaEntry])
forall a b. (a -> b) -> a -> b
$ [MetaEntry] -> [MetaEntry]
m ([MetaEntry] -> [MetaEntry])
-> ([MetaEntry] -> [MetaEntry]) -> [MetaEntry] -> [MetaEntry]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MetaEntry
meMetaEntry -> [MetaEntry] -> [MetaEntry]
forall a. a -> [a] -> [a]
:)
case Either SomeException ([MetaEntry] -> [MetaEntry])
eres of
Left e :: SomeException
e -> do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ "parseArchive of " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> ArchiveType -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display ArchiveType
at Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> ": " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> SomeException -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow SomeException
e
[ArchiveType] -> RIO env (ArchiveType, Map FilePath MetaEntry)
getFiles [ArchiveType]
ats
Right files :: [MetaEntry] -> [MetaEntry]
files -> (ArchiveType, Map FilePath MetaEntry)
-> RIO env (ArchiveType, Map FilePath MetaEntry)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ArchiveType
at, [(FilePath, MetaEntry)] -> Map FilePath MetaEntry
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(FilePath, MetaEntry)] -> Map FilePath MetaEntry)
-> [(FilePath, MetaEntry)] -> Map FilePath MetaEntry
forall a b. (a -> b) -> a -> b
$ (MetaEntry -> (FilePath, MetaEntry))
-> [MetaEntry] -> [(FilePath, MetaEntry)]
forall a b. (a -> b) -> [a] -> [b]
map (MetaEntry -> FilePath
mePath (MetaEntry -> FilePath)
-> (MetaEntry -> MetaEntry) -> MetaEntry -> (FilePath, MetaEntry)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& MetaEntry -> MetaEntry
forall a. a -> a
id) ([MetaEntry] -> [(FilePath, MetaEntry)])
-> [MetaEntry] -> [(FilePath, MetaEntry)]
forall a b. (a -> b) -> a -> b
$ [MetaEntry] -> [MetaEntry]
files [])
(ArchiveType
at :: ArchiveType, Map FilePath MetaEntry
files :: Map FilePath MetaEntry) <- [ArchiveType] -> RIO env (ArchiveType, Map FilePath MetaEntry)
forall env.
(HasPantryConfig env, HasLogFunc env) =>
[ArchiveType] -> RIO env (ArchiveType, Map FilePath MetaEntry)
getFiles [ArchiveType
forall a. Bounded a => a
minBound..ArchiveType
forall a. Bounded a => a
maxBound]
let toSimple :: FilePath -> MetaEntry -> Either String (Map FilePath SimpleEntry)
toSimple :: FilePath -> MetaEntry -> Either FilePath (Map FilePath SimpleEntry)
toSimple key :: FilePath
key me :: MetaEntry
me =
case MetaEntry -> METype
meType MetaEntry
me of
METNormal -> Map FilePath SimpleEntry
-> Either FilePath (Map FilePath SimpleEntry)
forall a b. b -> Either a b
Right (Map FilePath SimpleEntry
-> Either FilePath (Map FilePath SimpleEntry))
-> Map FilePath SimpleEntry
-> Either FilePath (Map FilePath SimpleEntry)
forall a b. (a -> b) -> a -> b
$ FilePath -> SimpleEntry -> Map FilePath SimpleEntry
forall k a. k -> a -> Map k a
Map.singleton FilePath
key (SimpleEntry -> Map FilePath SimpleEntry)
-> SimpleEntry -> Map FilePath SimpleEntry
forall a b. (a -> b) -> a -> b
$ FilePath -> FileType -> SimpleEntry
SimpleEntry (MetaEntry -> FilePath
mePath MetaEntry
me) FileType
FTNormal
METExecutable -> Map FilePath SimpleEntry
-> Either FilePath (Map FilePath SimpleEntry)
forall a b. b -> Either a b
Right (Map FilePath SimpleEntry
-> Either FilePath (Map FilePath SimpleEntry))
-> Map FilePath SimpleEntry
-> Either FilePath (Map FilePath SimpleEntry)
forall a b. (a -> b) -> a -> b
$ FilePath -> SimpleEntry -> Map FilePath SimpleEntry
forall k a. k -> a -> Map k a
Map.singleton FilePath
key (SimpleEntry -> Map FilePath SimpleEntry)
-> SimpleEntry -> Map FilePath SimpleEntry
forall a b. (a -> b) -> a -> b
$ FilePath -> FileType -> SimpleEntry
SimpleEntry (MetaEntry -> FilePath
mePath MetaEntry
me) FileType
FTExecutable
METLink relDest :: FilePath
relDest -> do
case FilePath
relDest of
'/':_ -> FilePath -> Either FilePath ()
forall a b. a -> Either a b
Left (FilePath -> Either FilePath ()) -> FilePath -> Either FilePath ()
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ "File located at "
, ShowS
forall a. Show a => a -> FilePath
show ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ MetaEntry -> FilePath
mePath MetaEntry
me
, " is a symbolic link to absolute path "
, FilePath
relDest
]
_ -> () -> Either FilePath ()
forall a b. b -> Either a b
Right ()
FilePath
dest0 <-
case FilePath -> FilePath -> Either FilePath FilePath
makeTarRelative (MetaEntry -> FilePath
mePath MetaEntry
me) FilePath
relDest of
Left e :: FilePath
e -> FilePath -> Either FilePath FilePath
forall a b. a -> Either a b
Left (FilePath -> Either FilePath FilePath)
-> FilePath -> Either FilePath FilePath
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ "Error resolving relative path "
, FilePath
relDest
, " from symlink at "
, MetaEntry -> FilePath
mePath MetaEntry
me
, ": "
, FilePath
e
]
Right x :: FilePath
x -> FilePath -> Either FilePath FilePath
forall a b. b -> Either a b
Right FilePath
x
FilePath
dest <-
case FilePath -> Either FilePath FilePath
normalizeParents FilePath
dest0 of
Left e :: FilePath
e -> FilePath -> Either FilePath FilePath
forall a b. a -> Either a b
Left (FilePath -> Either FilePath FilePath)
-> FilePath -> Either FilePath FilePath
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ "Invalid symbolic link from "
, MetaEntry -> FilePath
mePath MetaEntry
me
, " to "
, FilePath
relDest
, ", tried parsing "
, FilePath
dest0
, ": "
, FilePath
e
]
Right x :: FilePath
x -> FilePath -> Either FilePath FilePath
forall a b. b -> Either a b
Right FilePath
x
case FilePath -> Map FilePath MetaEntry -> Maybe MetaEntry
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FilePath
dest Map FilePath MetaEntry
files of
Nothing ->
case FilePath -> Map FilePath MetaEntry -> [(FilePath, MetaEntry)]
findWithPrefix FilePath
dest Map FilePath MetaEntry
files of
[] -> FilePath -> Either FilePath (Map FilePath SimpleEntry)
forall a b. a -> Either a b
Left (FilePath -> Either FilePath (Map FilePath SimpleEntry))
-> FilePath -> Either FilePath (Map FilePath SimpleEntry)
forall a b. (a -> b) -> a -> b
$ "Symbolic link dest not found from " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ MetaEntry -> FilePath
mePath MetaEntry
me FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ " to " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
relDest FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ ", looking for " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
dest FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ ".\n"
FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ "This may indicate that the source is a git archive which uses git-annex.\n"
FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ "See https://github.com/commercialhaskell/stack/issues/4579 for further information."
pairs :: [(FilePath, MetaEntry)]
pairs -> ([Map FilePath SimpleEntry] -> Map FilePath SimpleEntry)
-> Either FilePath [Map FilePath SimpleEntry]
-> Either FilePath (Map FilePath SimpleEntry)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Map FilePath SimpleEntry] -> Map FilePath SimpleEntry
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Either FilePath [Map FilePath SimpleEntry]
-> Either FilePath (Map FilePath SimpleEntry))
-> Either FilePath [Map FilePath SimpleEntry]
-> Either FilePath (Map FilePath SimpleEntry)
forall a b. (a -> b) -> a -> b
$ [(FilePath, MetaEntry)]
-> ((FilePath, MetaEntry)
-> Either FilePath (Map FilePath SimpleEntry))
-> Either FilePath [Map FilePath SimpleEntry]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(FilePath, MetaEntry)]
pairs (((FilePath, MetaEntry)
-> Either FilePath (Map FilePath SimpleEntry))
-> Either FilePath [Map FilePath SimpleEntry])
-> ((FilePath, MetaEntry)
-> Either FilePath (Map FilePath SimpleEntry))
-> Either FilePath [Map FilePath SimpleEntry]
forall a b. (a -> b) -> a -> b
$ \(suffix :: FilePath
suffix, me' :: MetaEntry
me') -> FilePath -> MetaEntry -> Either FilePath (Map FilePath SimpleEntry)
toSimple (FilePath
key FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ '/' Char -> ShowS
forall a. a -> [a] -> [a]
: FilePath
suffix) MetaEntry
me'
Just me' :: MetaEntry
me' ->
case MetaEntry -> METype
meType MetaEntry
me' of
METNormal -> Map FilePath SimpleEntry
-> Either FilePath (Map FilePath SimpleEntry)
forall a b. b -> Either a b
Right (Map FilePath SimpleEntry
-> Either FilePath (Map FilePath SimpleEntry))
-> Map FilePath SimpleEntry
-> Either FilePath (Map FilePath SimpleEntry)
forall a b. (a -> b) -> a -> b
$ FilePath -> SimpleEntry -> Map FilePath SimpleEntry
forall k a. k -> a -> Map k a
Map.singleton FilePath
key (SimpleEntry -> Map FilePath SimpleEntry)
-> SimpleEntry -> Map FilePath SimpleEntry
forall a b. (a -> b) -> a -> b
$ FilePath -> FileType -> SimpleEntry
SimpleEntry FilePath
dest FileType
FTNormal
METExecutable -> Map FilePath SimpleEntry
-> Either FilePath (Map FilePath SimpleEntry)
forall a b. b -> Either a b
Right (Map FilePath SimpleEntry
-> Either FilePath (Map FilePath SimpleEntry))
-> Map FilePath SimpleEntry
-> Either FilePath (Map FilePath SimpleEntry)
forall a b. (a -> b) -> a -> b
$ FilePath -> SimpleEntry -> Map FilePath SimpleEntry
forall k a. k -> a -> Map k a
Map.singleton FilePath
key (SimpleEntry -> Map FilePath SimpleEntry)
-> SimpleEntry -> Map FilePath SimpleEntry
forall a b. (a -> b) -> a -> b
$ FilePath -> FileType -> SimpleEntry
SimpleEntry FilePath
dest FileType
FTExecutable
METLink _ -> FilePath -> Either FilePath (Map FilePath SimpleEntry)
forall a b. a -> Either a b
Left (FilePath -> Either FilePath (Map FilePath SimpleEntry))
-> FilePath -> Either FilePath (Map FilePath SimpleEntry)
forall a b. (a -> b) -> a -> b
$ "Symbolic link dest cannot be a symbolic link, from " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ MetaEntry -> FilePath
mePath MetaEntry
me FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ " to " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
relDest
case Map FilePath (Map FilePath SimpleEntry) -> Map FilePath SimpleEntry
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Map FilePath (Map FilePath SimpleEntry)
-> Map FilePath SimpleEntry)
-> Either FilePath (Map FilePath (Map FilePath SimpleEntry))
-> Either FilePath (Map FilePath SimpleEntry)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath
-> MetaEntry -> Either FilePath (Map FilePath SimpleEntry))
-> Map FilePath MetaEntry
-> Either FilePath (Map FilePath (Map FilePath SimpleEntry))
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey FilePath -> MetaEntry -> Either FilePath (Map FilePath SimpleEntry)
toSimple Map FilePath MetaEntry
files of
Left e :: FilePath
e -> PantryException -> RIO env Package
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env Package)
-> PantryException -> RIO env Package
forall a b. (a -> b) -> a -> b
$ ArchiveLocation -> Text -> PantryException
UnsupportedTarball ArchiveLocation
loc (Text -> PantryException) -> Text -> PantryException
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
e
Right files1 :: Map FilePath SimpleEntry
files1 -> do
let files2 :: [(FilePath, SimpleEntry)]
files2 = [(FilePath, SimpleEntry)] -> [(FilePath, SimpleEntry)]
forall a. [(FilePath, a)] -> [(FilePath, a)]
stripCommonPrefix ([(FilePath, SimpleEntry)] -> [(FilePath, SimpleEntry)])
-> [(FilePath, SimpleEntry)] -> [(FilePath, SimpleEntry)]
forall a b. (a -> b) -> a -> b
$ Map FilePath SimpleEntry -> [(FilePath, SimpleEntry)]
forall k a. Map k a -> [(k, a)]
Map.toList Map FilePath SimpleEntry
files1
files3 :: [(Text, SimpleEntry)]
files3 = Text -> [(FilePath, SimpleEntry)] -> [(Text, SimpleEntry)]
forall a. Text -> [(FilePath, a)] -> [(Text, a)]
takeSubdir (RawArchive -> Text
raSubdir RawArchive
archive) [(FilePath, SimpleEntry)]
files2
toSafe :: (Text, b) -> Either FilePath (SafeFilePath, b)
toSafe (fp' :: Text
fp', a :: b
a) =
case Text -> Maybe SafeFilePath
mkSafeFilePath Text
fp' of
Nothing -> FilePath -> Either FilePath (SafeFilePath, b)
forall a b. a -> Either a b
Left (FilePath -> Either FilePath (SafeFilePath, b))
-> FilePath -> Either FilePath (SafeFilePath, b)
forall a b. (a -> b) -> a -> b
$ "Not a safe file path: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
forall a. Show a => a -> FilePath
show Text
fp'
Just sfp :: SafeFilePath
sfp -> (SafeFilePath, b) -> Either FilePath (SafeFilePath, b)
forall a b. b -> Either a b
Right (SafeFilePath
sfp, b
a)
case ((Text, SimpleEntry)
-> Either FilePath (SafeFilePath, SimpleEntry))
-> [(Text, SimpleEntry)]
-> Either FilePath [(SafeFilePath, SimpleEntry)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Text, SimpleEntry) -> Either FilePath (SafeFilePath, SimpleEntry)
forall b. (Text, b) -> Either FilePath (SafeFilePath, b)
toSafe [(Text, SimpleEntry)]
files3 of
Left e :: FilePath
e -> PantryException -> RIO env Package
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env Package)
-> PantryException -> RIO env Package
forall a b. (a -> b) -> a -> b
$ ArchiveLocation -> Text -> PantryException
UnsupportedTarball ArchiveLocation
loc (Text -> PantryException) -> Text -> PantryException
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
e
Right safeFiles :: [(SafeFilePath, SimpleEntry)]
safeFiles -> do
let toSave :: Set FilePath
toSave = [FilePath] -> Set FilePath
forall a. Ord a => [a] -> Set a
Set.fromList ([FilePath] -> Set FilePath) -> [FilePath] -> Set FilePath
forall a b. (a -> b) -> a -> b
$ ((SafeFilePath, SimpleEntry) -> FilePath)
-> [(SafeFilePath, SimpleEntry)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (SimpleEntry -> FilePath
seSource (SimpleEntry -> FilePath)
-> ((SafeFilePath, SimpleEntry) -> SimpleEntry)
-> (SafeFilePath, SimpleEntry)
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SafeFilePath, SimpleEntry) -> SimpleEntry
forall a b. (a, b) -> b
snd) [(SafeFilePath, SimpleEntry)]
safeFiles
(Map FilePath BlobKey
blobs :: Map FilePath BlobKey) <-
ArchiveLocation
-> FilePath
-> ArchiveType
-> Map FilePath BlobKey
-> (Map FilePath BlobKey
-> MetaEntry
-> ConduitT ByteString Void (RIO env) (Map FilePath BlobKey))
-> RIO env (Map FilePath BlobKey)
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ArchiveLocation
-> FilePath
-> ArchiveType
-> a
-> (a -> MetaEntry -> ConduitT ByteString Void (RIO env) a)
-> RIO env a
foldArchive ArchiveLocation
loc FilePath
fp ArchiveType
at Map FilePath BlobKey
forall a. Monoid a => a
mempty ((Map FilePath BlobKey
-> MetaEntry
-> ConduitT ByteString Void (RIO env) (Map FilePath BlobKey))
-> RIO env (Map FilePath BlobKey))
-> (Map FilePath BlobKey
-> MetaEntry
-> ConduitT ByteString Void (RIO env) (Map FilePath BlobKey))
-> RIO env (Map FilePath BlobKey)
forall a b. (a -> b) -> a -> b
$ \m :: Map FilePath BlobKey
m me :: MetaEntry
me ->
if MetaEntry -> FilePath
mePath MetaEntry
me FilePath -> Set FilePath -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set FilePath
toSave
then do
ByteString
bs <- [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat ([ByteString] -> ByteString)
-> ConduitT ByteString Void (RIO env) [ByteString]
-> ConduitT ByteString Void (RIO env) ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConduitT ByteString Void (RIO env) [ByteString]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
sinkList
(_, blobKey :: BlobKey
blobKey) <- RIO env (BlobId, BlobKey)
-> ConduitT ByteString Void (RIO env) (BlobId, BlobKey)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RIO env (BlobId, BlobKey)
-> ConduitT ByteString Void (RIO env) (BlobId, BlobKey))
-> RIO env (BlobId, BlobKey)
-> ConduitT ByteString Void (RIO env) (BlobId, BlobKey)
forall a b. (a -> b) -> a -> b
$ ReaderT SqlBackend (RIO env) (BlobId, BlobKey)
-> RIO env (BlobId, BlobKey)
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) (BlobId, BlobKey)
-> RIO env (BlobId, BlobKey))
-> ReaderT SqlBackend (RIO env) (BlobId, BlobKey)
-> RIO env (BlobId, BlobKey)
forall a b. (a -> b) -> a -> b
$ ByteString -> ReaderT SqlBackend (RIO env) (BlobId, BlobKey)
forall env.
ByteString -> ReaderT SqlBackend (RIO env) (BlobId, BlobKey)
storeBlob ByteString
bs
Map FilePath BlobKey
-> ConduitT ByteString Void (RIO env) (Map FilePath BlobKey)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map FilePath BlobKey
-> ConduitT ByteString Void (RIO env) (Map FilePath BlobKey))
-> Map FilePath BlobKey
-> ConduitT ByteString Void (RIO env) (Map FilePath BlobKey)
forall a b. (a -> b) -> a -> b
$ FilePath -> BlobKey -> Map FilePath BlobKey -> Map FilePath BlobKey
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (MetaEntry -> FilePath
mePath MetaEntry
me) BlobKey
blobKey Map FilePath BlobKey
m
else Map FilePath BlobKey
-> ConduitT ByteString Void (RIO env) (Map FilePath BlobKey)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map FilePath BlobKey
m
Tree
tree <- ([(SafeFilePath, TreeEntry)] -> Tree)
-> RIO env [(SafeFilePath, TreeEntry)] -> RIO env Tree
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map SafeFilePath TreeEntry -> Tree
TreeMap (Map SafeFilePath TreeEntry -> Tree)
-> ([(SafeFilePath, TreeEntry)] -> Map SafeFilePath TreeEntry)
-> [(SafeFilePath, TreeEntry)]
-> Tree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SafeFilePath, TreeEntry)] -> Map SafeFilePath TreeEntry
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList) (RIO env [(SafeFilePath, TreeEntry)] -> RIO env Tree)
-> RIO env [(SafeFilePath, TreeEntry)] -> RIO env Tree
forall a b. (a -> b) -> a -> b
$ [(SafeFilePath, SimpleEntry)]
-> ((SafeFilePath, SimpleEntry)
-> RIO env (SafeFilePath, TreeEntry))
-> RIO env [(SafeFilePath, TreeEntry)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(SafeFilePath, SimpleEntry)]
safeFiles (((SafeFilePath, SimpleEntry) -> RIO env (SafeFilePath, TreeEntry))
-> RIO env [(SafeFilePath, TreeEntry)])
-> ((SafeFilePath, SimpleEntry)
-> RIO env (SafeFilePath, TreeEntry))
-> RIO env [(SafeFilePath, TreeEntry)]
forall a b. (a -> b) -> a -> b
$ \(sfp :: SafeFilePath
sfp, se :: SimpleEntry
se) ->
case FilePath -> Map FilePath BlobKey -> Maybe BlobKey
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (SimpleEntry -> FilePath
seSource SimpleEntry
se) Map FilePath BlobKey
blobs of
Nothing -> FilePath -> RIO env (SafeFilePath, TreeEntry)
forall a. HasCallStack => FilePath -> a
error (FilePath -> RIO env (SafeFilePath, TreeEntry))
-> FilePath -> RIO env (SafeFilePath, TreeEntry)
forall a b. (a -> b) -> a -> b
$ "Impossible: blob not found for: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ SimpleEntry -> FilePath
seSource SimpleEntry
se
Just blobKey :: BlobKey
blobKey -> (SafeFilePath, TreeEntry) -> RIO env (SafeFilePath, TreeEntry)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SafeFilePath
sfp, BlobKey -> FileType -> TreeEntry
TreeEntry BlobKey
blobKey (SimpleEntry -> FileType
seType SimpleEntry
se))
BuildFile
buildFile <- RawPackageLocationImmutable -> Tree -> RIO env BuildFile
forall (m :: * -> *).
MonadThrow m =>
RawPackageLocationImmutable -> Tree -> m BuildFile
findCabalOrHpackFile RawPackageLocationImmutable
rpli Tree
tree
(buildFilePath :: SafeFilePath
buildFilePath, buildFileBlobKey :: BlobKey
buildFileBlobKey, buildFileEntry :: TreeEntry
buildFileEntry) <- case BuildFile
buildFile of
BFCabal fpath :: SafeFilePath
fpath te :: TreeEntry
te@(TreeEntry key :: BlobKey
key _) -> (SafeFilePath, BlobKey, TreeEntry)
-> RIO env (SafeFilePath, BlobKey, TreeEntry)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SafeFilePath
fpath, BlobKey
key, TreeEntry
te)
BFHpack te :: TreeEntry
te@(TreeEntry key :: BlobKey
key _) -> (SafeFilePath, BlobKey, TreeEntry)
-> RIO env (SafeFilePath, BlobKey, TreeEntry)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SafeFilePath
hpackSafeFilePath, BlobKey
key, TreeEntry
te)
Maybe ByteString
mbs <- ReaderT SqlBackend (RIO env) (Maybe ByteString)
-> RIO env (Maybe ByteString)
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) (Maybe ByteString)
-> RIO env (Maybe ByteString))
-> ReaderT SqlBackend (RIO env) (Maybe ByteString)
-> RIO env (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ BlobKey -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
forall env.
HasLogFunc env =>
BlobKey -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
loadBlob BlobKey
buildFileBlobKey
ByteString
bs <-
case Maybe ByteString
mbs of
Nothing -> PantryException -> RIO env ByteString
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env ByteString)
-> PantryException -> RIO env ByteString
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable
-> SafeFilePath -> BlobKey -> PantryException
TreeReferencesMissingBlob RawPackageLocationImmutable
rpli SafeFilePath
buildFilePath BlobKey
buildFileBlobKey
Just bs :: ByteString
bs -> ByteString -> RIO env ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs
ByteString
cabalBs <- case BuildFile
buildFile of
BFCabal _ _ -> ByteString -> RIO env ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs
BFHpack _ -> (PackageName, ByteString) -> ByteString
forall a b. (a, b) -> b
snd ((PackageName, ByteString) -> ByteString)
-> RIO env (PackageName, ByteString) -> RIO env ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawPackageLocationImmutable
-> Tree -> RIO env (PackageName, ByteString)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> Tree -> RIO env (PackageName, ByteString)
hpackToCabal RawPackageLocationImmutable
rpli Tree
tree
(_warnings :: [PWarning]
_warnings, gpd :: GenericPackageDescription
gpd) <- Either RawPackageLocationImmutable (Path Abs File)
-> ByteString -> RIO env ([PWarning], GenericPackageDescription)
forall (m :: * -> *).
MonadThrow m =>
Either RawPackageLocationImmutable (Path Abs File)
-> ByteString -> m ([PWarning], GenericPackageDescription)
rawParseGPD (RawPackageLocationImmutable
-> Either RawPackageLocationImmutable (Path Abs File)
forall a b. a -> Either a b
Left RawPackageLocationImmutable
rpli) ByteString
cabalBs
let ident :: PackageIdentifier
ident@(PackageIdentifier name :: PackageName
name _) = PackageDescription -> PackageIdentifier
package (PackageDescription -> PackageIdentifier)
-> PackageDescription -> PackageIdentifier
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
packageDescription GenericPackageDescription
gpd
case BuildFile
buildFile of
BFCabal _ _ -> Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SafeFilePath
buildFilePath SafeFilePath -> SafeFilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= PackageName -> SafeFilePath
cabalFileName PackageName
name) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ PantryException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env ()) -> PantryException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable
-> SafeFilePath -> PackageName -> PantryException
WrongCabalFileName RawPackageLocationImmutable
rpli SafeFilePath
buildFilePath PackageName
name
_ -> () -> RIO env ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(tid :: TreeId
tid, treeKey' :: TreeKey
treeKey') <- ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
-> RIO env (TreeId, TreeKey)
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
-> RIO env (TreeId, TreeKey))
-> ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
-> RIO env (TreeId, TreeKey)
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable
-> PackageIdentifier
-> Tree
-> BuildFile
-> ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> PackageIdentifier
-> Tree
-> BuildFile
-> ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
storeTree RawPackageLocationImmutable
rpli PackageIdentifier
ident Tree
tree BuildFile
buildFile
PackageCabal
packageCabal <- case BuildFile
buildFile of
BFCabal _ _ -> PackageCabal -> RIO env PackageCabal
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageCabal -> RIO env PackageCabal)
-> PackageCabal -> RIO env PackageCabal
forall a b. (a -> b) -> a -> b
$ TreeEntry -> PackageCabal
PCCabalFile TreeEntry
buildFileEntry
BFHpack _ -> do
BlobKey
cabalKey <- ReaderT SqlBackend (RIO env) BlobKey -> RIO env BlobKey
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) BlobKey -> RIO env BlobKey)
-> ReaderT SqlBackend (RIO env) BlobKey -> RIO env BlobKey
forall a b. (a -> b) -> a -> b
$ do
Key HPack
hpackId <- RawPackageLocationImmutable
-> TreeId -> ReaderT SqlBackend (RIO env) (Key HPack)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> TreeId -> ReaderT SqlBackend (RIO env) (Key HPack)
storeHPack RawPackageLocationImmutable
rpli TreeId
tid
Key HPack -> ReaderT SqlBackend (RIO env) BlobKey
forall env. Key HPack -> ReaderT SqlBackend (RIO env) BlobKey
loadCabalBlobKey Key HPack
hpackId
Version
hpackSoftwareVersion <- RIO env Version
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RIO env Version
hpackVersion
let cabalTreeEntry :: TreeEntry
cabalTreeEntry = BlobKey -> FileType -> TreeEntry
TreeEntry BlobKey
cabalKey (TreeEntry -> FileType
teType TreeEntry
buildFileEntry)
PackageCabal -> RIO env PackageCabal
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageCabal -> RIO env PackageCabal)
-> PackageCabal -> RIO env PackageCabal
forall a b. (a -> b) -> a -> b
$ PHpack -> PackageCabal
PCHpack (PHpack -> PackageCabal) -> PHpack -> PackageCabal
forall a b. (a -> b) -> a -> b
$ $WPHpack :: TreeEntry -> TreeEntry -> Version -> PHpack
PHpack { phOriginal :: TreeEntry
phOriginal = TreeEntry
buildFileEntry, phGenerated :: TreeEntry
phGenerated = TreeEntry
cabalTreeEntry, phVersion :: Version
phVersion = Version
hpackSoftwareVersion}
Package -> RIO env Package
forall (f :: * -> *) a. Applicative f => a -> f a
pure $WPackage :: TreeKey -> Tree -> PackageCabal -> PackageIdentifier -> Package
Package
{ packageTreeKey :: TreeKey
packageTreeKey = TreeKey
treeKey'
, packageTree :: Tree
packageTree = Tree
tree
, packageCabalEntry :: PackageCabal
packageCabalEntry = PackageCabal
packageCabal
, packageIdent :: PackageIdentifier
packageIdent = PackageIdentifier
ident
}
findWithPrefix :: FilePath -> Map FilePath MetaEntry -> [(FilePath, MetaEntry)]
findWithPrefix :: FilePath -> Map FilePath MetaEntry -> [(FilePath, MetaEntry)]
findWithPrefix dir :: FilePath
dir = ((FilePath, MetaEntry) -> Maybe (FilePath, MetaEntry))
-> [(FilePath, MetaEntry)] -> [(FilePath, MetaEntry)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (FilePath, MetaEntry) -> Maybe (FilePath, MetaEntry)
forall t. (FilePath, t) -> Maybe (FilePath, t)
go ([(FilePath, MetaEntry)] -> [(FilePath, MetaEntry)])
-> (Map FilePath MetaEntry -> [(FilePath, MetaEntry)])
-> Map FilePath MetaEntry
-> [(FilePath, MetaEntry)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map FilePath MetaEntry -> [(FilePath, MetaEntry)]
forall k a. Map k a -> [(k, a)]
Map.toList
where
prefix :: FilePath
prefix = FilePath
dir FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ "/"
go :: (FilePath, t) -> Maybe (FilePath, t)
go (x :: FilePath
x, y :: t
y) = (, t
y) (FilePath -> (FilePath, t))
-> Maybe FilePath -> Maybe (FilePath, t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripPrefix FilePath
prefix FilePath
x
findCabalOrHpackFile
:: MonadThrow m
=> RawPackageLocationImmutable
-> Tree
-> m BuildFile
findCabalOrHpackFile :: RawPackageLocationImmutable -> Tree -> m BuildFile
findCabalOrHpackFile loc :: RawPackageLocationImmutable
loc (TreeMap m :: Map SafeFilePath TreeEntry
m) = do
let isCabalFile :: (SafeFilePath, b) -> Bool
isCabalFile (sfp :: SafeFilePath
sfp, _) =
let txt :: Text
txt = SafeFilePath -> Text
unSafeFilePath SafeFilePath
sfp
in Bool -> Bool
not ("/" Text -> Text -> Bool
`T.isInfixOf` Text
txt) Bool -> Bool -> Bool
&& (".cabal" Text -> Text -> Bool
`T.isSuffixOf` Text
txt)
isHpackFile :: (SafeFilePath, b) -> Bool
isHpackFile (sfp :: SafeFilePath
sfp, _) =
let txt :: Text
txt = SafeFilePath -> Text
unSafeFilePath SafeFilePath
sfp
in FilePath -> Text
T.pack (FilePath
Hpack.packageConfig) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
txt
isBFCabal :: BuildFile -> Bool
isBFCabal (BFCabal _ _) = Bool
True
isBFCabal _ = Bool
False
sfpBuildFile :: BuildFile -> SafeFilePath
sfpBuildFile (BFCabal sfp :: SafeFilePath
sfp _) = SafeFilePath
sfp
sfpBuildFile (BFHpack _) = SafeFilePath
hpackSafeFilePath
toBuildFile :: (SafeFilePath, TreeEntry) -> Maybe BuildFile
toBuildFile xs :: (SafeFilePath, TreeEntry)
xs@(sfp :: SafeFilePath
sfp, te :: TreeEntry
te) = let cbFile :: Maybe BuildFile
cbFile = if ((SafeFilePath, TreeEntry) -> Bool
forall b. (SafeFilePath, b) -> Bool
isCabalFile (SafeFilePath, TreeEntry)
xs)
then BuildFile -> Maybe BuildFile
forall a. a -> Maybe a
Just (BuildFile -> Maybe BuildFile) -> BuildFile -> Maybe BuildFile
forall a b. (a -> b) -> a -> b
$ SafeFilePath -> TreeEntry -> BuildFile
BFCabal SafeFilePath
sfp TreeEntry
te
else Maybe BuildFile
forall a. Maybe a
Nothing
hpFile :: Maybe BuildFile
hpFile = if ((SafeFilePath, TreeEntry) -> Bool
forall b. (SafeFilePath, b) -> Bool
isHpackFile (SafeFilePath, TreeEntry)
xs)
then BuildFile -> Maybe BuildFile
forall a. a -> Maybe a
Just (BuildFile -> Maybe BuildFile) -> BuildFile -> Maybe BuildFile
forall a b. (a -> b) -> a -> b
$ TreeEntry -> BuildFile
BFHpack TreeEntry
te
else Maybe BuildFile
forall a. Maybe a
Nothing
in Maybe BuildFile
cbFile Maybe BuildFile -> Maybe BuildFile -> Maybe BuildFile
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe BuildFile
hpFile
case ((SafeFilePath, TreeEntry) -> Maybe BuildFile)
-> [(SafeFilePath, TreeEntry)] -> [BuildFile]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (SafeFilePath, TreeEntry) -> Maybe BuildFile
toBuildFile ([(SafeFilePath, TreeEntry)] -> [BuildFile])
-> [(SafeFilePath, TreeEntry)] -> [BuildFile]
forall a b. (a -> b) -> a -> b
$ Map SafeFilePath TreeEntry -> [(SafeFilePath, TreeEntry)]
forall k a. Map k a -> [(k, a)]
Map.toList Map SafeFilePath TreeEntry
m of
[] -> PantryException -> m BuildFile
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (PantryException -> m BuildFile) -> PantryException -> m BuildFile
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable -> PantryException
TreeWithoutCabalFile RawPackageLocationImmutable
loc
[bfile :: BuildFile
bfile] -> BuildFile -> m BuildFile
forall (f :: * -> *) a. Applicative f => a -> f a
pure BuildFile
bfile
xs :: [BuildFile]
xs -> case ((BuildFile -> Bool) -> [BuildFile] -> [BuildFile]
forall a. (a -> Bool) -> [a] -> [a]
filter BuildFile -> Bool
isBFCabal [BuildFile]
xs) of
[] -> PantryException -> m BuildFile
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (PantryException -> m BuildFile) -> PantryException -> m BuildFile
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable -> PantryException
TreeWithoutCabalFile RawPackageLocationImmutable
loc
[bfile :: BuildFile
bfile] -> BuildFile -> m BuildFile
forall (f :: * -> *) a. Applicative f => a -> f a
pure BuildFile
bfile
xs' :: [BuildFile]
xs' -> PantryException -> m BuildFile
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (PantryException -> m BuildFile) -> PantryException -> m BuildFile
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable -> [SafeFilePath] -> PantryException
TreeWithMultipleCabalFiles RawPackageLocationImmutable
loc ([SafeFilePath] -> PantryException)
-> [SafeFilePath] -> PantryException
forall a b. (a -> b) -> a -> b
$ (BuildFile -> SafeFilePath) -> [BuildFile] -> [SafeFilePath]
forall a b. (a -> b) -> [a] -> [b]
map BuildFile -> SafeFilePath
sfpBuildFile [BuildFile]
xs'
stripCommonPrefix :: [(FilePath, a)] -> [(FilePath, a)]
stripCommonPrefix :: [(FilePath, a)] -> [(FilePath, a)]
stripCommonPrefix [] = []
stripCommonPrefix pairs :: [(FilePath, a)]
pairs@((firstFP :: FilePath
firstFP, _):_) = [(FilePath, a)] -> Maybe [(FilePath, a)] -> [(FilePath, a)]
forall a. a -> Maybe a -> a
fromMaybe [(FilePath, a)]
pairs (Maybe [(FilePath, a)] -> [(FilePath, a)])
-> Maybe [(FilePath, a)] -> [(FilePath, a)]
forall a b. (a -> b) -> a -> b
$ do
let firstDir :: FilePath
firstDir = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '/') FilePath
firstFP
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
firstDir
let strip :: (FilePath, t) -> Maybe (FilePath, t)
strip (fp :: FilePath
fp, a :: t
a) = (, t
a) (FilePath -> (FilePath, t))
-> Maybe FilePath -> Maybe (FilePath, t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripPrefix (FilePath
firstDir FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ "/") FilePath
fp
[(FilePath, a)] -> [(FilePath, a)]
forall a. [(FilePath, a)] -> [(FilePath, a)]
stripCommonPrefix ([(FilePath, a)] -> [(FilePath, a)])
-> Maybe [(FilePath, a)] -> Maybe [(FilePath, a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((FilePath, a) -> Maybe (FilePath, a))
-> [(FilePath, a)] -> Maybe [(FilePath, a)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (FilePath, a) -> Maybe (FilePath, a)
forall t. (FilePath, t) -> Maybe (FilePath, t)
strip [(FilePath, a)]
pairs
takeSubdir
:: Text
-> [(FilePath, a)]
-> [(Text, a)]
takeSubdir :: Text -> [(FilePath, a)] -> [(Text, a)]
takeSubdir subdir :: Text
subdir = ((FilePath, a) -> Maybe (Text, a))
-> [(FilePath, a)] -> [(Text, a)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (((FilePath, a) -> Maybe (Text, a))
-> [(FilePath, a)] -> [(Text, a)])
-> ((FilePath, a) -> Maybe (Text, a))
-> [(FilePath, a)]
-> [(Text, a)]
forall a b. (a -> b) -> a -> b
$ \(fp :: FilePath
fp, a :: a
a) -> do
[Text]
stripped <- [Text] -> [Text] -> Maybe [Text]
forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripPrefix [Text]
subdirs ([Text] -> Maybe [Text]) -> [Text] -> Maybe [Text]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
splitDirs (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
fp
(Text, a) -> Maybe (Text, a)
forall a. a -> Maybe a
Just (Text -> [Text] -> Text
T.intercalate "/" [Text]
stripped, a
a)
where
splitDirs :: Text -> [Text]
splitDirs = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
List.dropWhile (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== ".") ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= "") ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> [Text]
T.splitOn "/"
subdirs :: [Text]
subdirs = Text -> [Text]
splitDirs Text
subdir