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