{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Pantry.Archive
( getArchivePackage
, getArchive
, getArchiveKey
, fetchArchivesRaw
, fetchArchives
, findCabalOrHpackFile
) where
import qualified Codec.Archive.Zip as Zip
import Conduit
( ConduitT, (.|), runConduit, sinkHandle, sinkList
, sourceHandle, sourceLazy, withSourceFile
)
import Data.Bits ( (.&.), shiftR )
import qualified Data.Conduit.Tar as Tar
import Data.Conduit.Zlib ( ungzip )
import qualified Data.Digest.CRC32 as CRC32
import Distribution.PackageDescription ( package, packageDescription )
import qualified Hpack.Config as Hpack
import Pantry.HPack ( hpackVersion )
import Pantry.HTTP ( httpSinkChecked )
import Pantry.Internal ( makeTarRelative, normalizeParents )
import qualified Pantry.SHA256 as SHA256
import Pantry.Storage
( BlobId, CachedTree (..), TreeId, hpackToCabal
, loadArchiveCache, loadBlob, loadCabalBlobKey
, loadCachedTree, loadPackageById, storeArchiveCache
, storeBlob, storeHPack, storeTree, unCachedTree, withStorage
)
import Pantry.Tree ( rawParseGPD )
import Pantry.Types
( Archive, ArchiveLocation (..), BlobKey, BuildFile (..)
, FileSize (..), FileType (..), HasPantryConfig
, Mismatch (..), Package (..), PackageCabal (..)
, PackageIdentifier (..), PackageMetadata (..)
, PantryException (..), PHpack (..), RawArchive (..)
, RawPackageLocationImmutable (..), RawPackageMetadata (..)
, ResolvedPath (..), SHA256, Tree (..), TreeEntry (..)
, TreeKey, cabalFileName, hpackSafeFilePath, mkSafeFilePath
, toRawArchive, toRawPM, unSafeFilePath
)
import Path ( toFilePath )
import Path.IO ( doesFileExist )
import RIO
import qualified RIO.ByteString.Lazy as BL
import qualified RIO.List as List
import qualified RIO.Map as Map
import RIO.Process ( HasProcessContext )
import qualified RIO.Set as Set
import qualified RIO.Text as T
import qualified RIO.Text.Partial as T
fetchArchivesRaw ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> [(RawArchive, RawPackageMetadata)]
-> RIO env ()
fetchArchivesRaw :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
[(RawArchive, RawPackageMetadata)] -> RIO env ()
fetchArchivesRaw [(RawArchive, RawPackageMetadata)]
pairs =
[(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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
[(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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
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 :: forall a b c d. (a, b, c, d) -> c
thd4 (a
_, b
_, c
z, d
_) = c
z
getArchivePackage ::
forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env, HasCallStack)
=> RawPackageLocationImmutable
-> RawArchive
-> RawPackageMetadata
-> RIO env Package
getArchivePackage :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env,
HasCallStack) =>
RawPackageLocationImmutable
-> RawArchive -> RawPackageMetadata -> RIO env Package
getArchivePackage RawPackageLocationImmutable
rpli RawArchive
archive RawPackageMetadata
rpm = (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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env,
HasCallStack) =>
RawPackageLocationImmutable
-> RawArchive
-> RawPackageMetadata
-> RIO env (SHA256, FileSize, Package, CachedTree)
getArchive RawPackageLocationImmutable
rpli RawArchive
archive RawPackageMetadata
rpm = do
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 a. a -> RIO env a
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 a. a -> RIO env a
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 a. a -> RIO env a
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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SHA256
a, FileSize
b, Package
c, CachedTree
d)
(Maybe (SHA256, FileSize, Package), Maybe CachedTree)
_ -> RawArchive
-> ([Char]
-> SHA256
-> FileSize
-> RIO env (SHA256, FileSize, Package, CachedTree))
-> RIO env (SHA256, FileSize, Package, CachedTree)
forall env a.
HasLogFunc env =>
RawArchive
-> ([Char] -> SHA256 -> FileSize -> RIO env a) -> RIO env a
withArchiveLoc RawArchive
archive (([Char]
-> SHA256
-> FileSize
-> RIO env (SHA256, FileSize, Package, CachedTree))
-> RIO env (SHA256, FileSize, Package, CachedTree))
-> ([Char]
-> SHA256
-> FileSize
-> RIO env (SHA256, FileSize, Package, CachedTree))
-> RIO env (SHA256, FileSize, Package, CachedTree)
forall a b. (a -> b) -> a -> b
$ \[Char]
fp SHA256
sha FileSize
size -> do
(Package
pa, CachedTree
tree) <- RawPackageLocationImmutable
-> RawArchive -> [Char] -> RIO env (Package, CachedTree)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> RawArchive -> [Char] -> RIO env (Package, CachedTree)
parseArchive RawPackageLocationImmutable
rpli RawArchive
archive [Char]
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 a. a -> RIO env a
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 a. a -> RIO env a
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 :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawArchive -> SHA256 -> FileSize -> Package -> RIO env ()
storeCache RawArchive
archive SHA256
sha FileSize
size Package
pa =
case RawArchive -> ArchiveLocation
raLocation RawArchive
archive of
ALUrl Text
url -> 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 a. a -> RIO env a
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 :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> RawArchive -> RIO env (Maybe (SHA256, FileSize, Package))
loadCache RawPackageLocationImmutable
rpli RawArchive
archive =
case ArchiveLocation
loc of
ALFilePath ResolvedPath File
_ -> Maybe (SHA256, FileSize, Package)
-> RIO env (Maybe (SHA256, FileSize, Package))
forall a. a -> RIO env a
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 a b. RIO env a -> (a -> RIO env b) -> RIO env b
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 a b. (a -> b) -> RIO env a -> RIO env b
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 a. a -> RIO env a
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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(Package -> (SHA256, FileSize, Package))
-> Maybe Package -> Maybe (SHA256, FileSize, Package)
forall a b. (a -> b) -> Maybe a -> Maybe b
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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(Package -> (SHA256, FileSize, Package))
-> Maybe Package -> Maybe (SHA256, FileSize, Package)
forall a b. (a -> b) -> Maybe a -> Maybe b
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 a b. (a -> b) -> Maybe a -> Maybe b
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 :: forall a. Eq a => 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 :: forall env a.
HasLogFunc env =>
RawArchive
-> ([Char] -> SHA256 -> FileSize -> RIO env a) -> RIO env a
withArchiveLoc (RawArchive (ALFilePath ResolvedPath File
resolved) Maybe SHA256
msha Maybe FileSize
msize Text
_subdir) [Char] -> SHA256 -> FileSize -> RIO env a
f = do
let abs' :: Path Abs File
abs' = ResolvedPath File -> Path Abs File
forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath File
resolved
fp :: [Char]
fp = Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
abs'
Bool
archiveExists <- Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
abs'
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
archiveExists (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 -> PantryException
LocalNoArchiveFileFound Path Abs File
abs'
(SHA256
sha, FileSize
size) <- [Char]
-> IOMode
-> (Handle -> RIO env (SHA256, FileSize))
-> RIO env (SHA256, FileSize)
forall (m :: * -> *) a.
MonadUnliftIO m =>
[Char] -> IOMode -> (Handle -> m a) -> m a
withBinaryFile [Char]
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
{ 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) ()
-> ConduitT ByteString Void (RIO env) SHA256
-> ConduitT () Void (RIO env) SHA256
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT 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
{ mismatchExpected :: SHA256
mismatchExpected = SHA256
sha'
, mismatchActual :: SHA256
mismatchActual = SHA256
sha
}
(SHA256, FileSize) -> RIO env (SHA256, FileSize)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SHA256
sha, FileSize
size)
[Char] -> SHA256 -> FileSize -> RIO env a
f [Char]
fp SHA256
sha FileSize
size
withArchiveLoc (RawArchive (ALUrl Text
url) Maybe SHA256
msha Maybe FileSize
msize Text
_subdir) [Char] -> SHA256 -> FileSize -> RIO env a
f =
[Char] -> ([Char] -> Handle -> RIO env a) -> RIO env a
forall (m :: * -> *) a.
MonadUnliftIO m =>
[Char] -> ([Char] -> Handle -> m a) -> m a
withSystemTempFile [Char]
"archive" (([Char] -> Handle -> RIO env a) -> RIO env a)
-> ([Char] -> Handle -> RIO env a) -> RIO env a
forall a b. (a -> b) -> a -> b
$ \[Char]
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
[Char] -> SHA256 -> FileSize -> RIO env a
f [Char]
fp SHA256
sha FileSize
size
data ArchiveType = ATTarGz | ATTar | ATZip
deriving (Int -> ArchiveType
ArchiveType -> Int
ArchiveType -> [ArchiveType]
ArchiveType -> ArchiveType
ArchiveType -> ArchiveType -> [ArchiveType]
ArchiveType -> ArchiveType -> ArchiveType -> [ArchiveType]
(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
$csucc :: ArchiveType -> ArchiveType
succ :: ArchiveType -> ArchiveType
$cpred :: ArchiveType -> ArchiveType
pred :: ArchiveType -> ArchiveType
$ctoEnum :: Int -> ArchiveType
toEnum :: Int -> ArchiveType
$cfromEnum :: ArchiveType -> Int
fromEnum :: ArchiveType -> Int
$cenumFrom :: ArchiveType -> [ArchiveType]
enumFrom :: ArchiveType -> [ArchiveType]
$cenumFromThen :: ArchiveType -> ArchiveType -> [ArchiveType]
enumFromThen :: ArchiveType -> ArchiveType -> [ArchiveType]
$cenumFromTo :: ArchiveType -> ArchiveType -> [ArchiveType]
enumFromTo :: ArchiveType -> ArchiveType -> [ArchiveType]
$cenumFromThenTo :: ArchiveType -> ArchiveType -> ArchiveType -> [ArchiveType]
enumFromThenTo :: ArchiveType -> ArchiveType -> ArchiveType -> [ArchiveType]
Enum, ArchiveType
ArchiveType -> ArchiveType -> Bounded ArchiveType
forall a. a -> a -> Bounded a
$cminBound :: ArchiveType
minBound :: ArchiveType
$cmaxBound :: ArchiveType
maxBound :: ArchiveType
Bounded)
instance Display ArchiveType where
display :: ArchiveType -> Utf8Builder
display ArchiveType
ATTarGz = Utf8Builder
"GZIP-ed tar file"
display ArchiveType
ATTar = Utf8Builder
"Uncompressed tar file"
display ArchiveType
ATZip = Utf8Builder
"Zip file"
data METype
= METNormal
| METExecutable
| METLink !FilePath
deriving Int -> METype -> ShowS
[METype] -> ShowS
METype -> [Char]
(Int -> METype -> ShowS)
-> (METype -> [Char]) -> ([METype] -> ShowS) -> Show METype
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> METype -> ShowS
showsPrec :: Int -> METype -> ShowS
$cshow :: METype -> [Char]
show :: METype -> [Char]
$cshowList :: [METype] -> ShowS
showList :: [METype] -> ShowS
Show
data MetaEntry = MetaEntry
{ MetaEntry -> [Char]
mePath :: !FilePath
, MetaEntry -> METype
meType :: !METype
}
deriving Int -> MetaEntry -> ShowS
[MetaEntry] -> ShowS
MetaEntry -> [Char]
(Int -> MetaEntry -> ShowS)
-> (MetaEntry -> [Char])
-> ([MetaEntry] -> ShowS)
-> Show MetaEntry
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MetaEntry -> ShowS
showsPrec :: Int -> MetaEntry -> ShowS
$cshow :: MetaEntry -> [Char]
show :: MetaEntry -> [Char]
$cshowList :: [MetaEntry] -> ShowS
showList :: [MetaEntry] -> ShowS
Show
foldArchive ::
(HasPantryConfig env, HasLogFunc env)
=> ArchiveLocation
-> FilePath
-> ArchiveType
-> a
-> (a -> MetaEntry -> ConduitT ByteString Void (RIO env) a)
-> RIO env a
foldArchive :: forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ArchiveLocation
-> [Char]
-> ArchiveType
-> a
-> (a -> MetaEntry -> ConduitT ByteString Void (RIO env) a)
-> RIO env a
foldArchive ArchiveLocation
loc [Char]
fp ArchiveType
ATTarGz a
accum a -> MetaEntry -> ConduitT ByteString Void (RIO env) a
f =
[Char]
-> (ConduitM () ByteString (RIO env) () -> RIO env a) -> RIO env a
forall (m :: * -> *) (n :: * -> *) i a.
(MonadUnliftIO m, MonadIO n) =>
[Char] -> (ConduitM i ByteString n () -> m a) -> m a
withSourceFile [Char]
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 =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT 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 =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT 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 [Char]
fp ArchiveType
ATTar a
accum a -> MetaEntry -> ConduitT ByteString Void (RIO env) a
f =
[Char]
-> (ConduitM () ByteString (RIO env) () -> RIO env a) -> RIO env a
forall (m :: * -> *) (n :: * -> *) i a.
(MonadUnliftIO m, MonadIO n) =>
[Char] -> (ConduitM i ByteString n () -> m a) -> m a
withSourceFile [Char]
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 =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT 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 [Char]
fp ArchiveType
ATZip a
accum0 a -> MetaEntry -> ConduitT ByteString Void (RIO env) a
f = [Char] -> IOMode -> (Handle -> RIO env a) -> RIO env a
forall (m :: * -> *) a.
MonadUnliftIO m =>
[Char] -> IOMode -> (Handle -> m a) -> m a
withBinaryFile [Char]
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 normalizedRelPath :: [Char]
normalizedRelPath = ShowS
removeInitialDotSlash ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Entry -> [Char]
Zip.eRelativePath Entry
entry
me :: MetaEntry
me = [Char] -> METype -> MetaEntry
MetaEntry [Char]
normalizedRelPath METype
met
met :: METype
met = 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 -> [Char] -> Mismatch Word32 -> PantryException
CRC32Mismatch ArchiveLocation
loc (Entry -> [Char]
Zip.eRelativePath Entry
entry) 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 =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| a -> MetaEntry -> ConduitT ByteString Void (RIO env) a
f a
accum MetaEntry
me
isDir :: Entry -> Bool
isDir Entry
entry =
case ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Entry -> [Char]
Zip.eRelativePath Entry
entry of
Char
'/':[Char]
_ -> Bool
True
[Char]
_ -> 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 :: forall env a o.
(HasPantryConfig env, HasLogFunc env) =>
ArchiveLocation
-> a
-> (a -> MetaEntry -> ConduitT ByteString o (RIO env) a)
-> ConduitT ByteString o (RIO env) a
foldTar ArchiveLocation
loc a
accum0 a -> MetaEntry -> ConduitT ByteString o (RIO env) a
f = do
IORef a
ref <- 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 -> ConduitT ByteString o (RIO env) (Maybe MetaEntry)
forall (m :: * -> *). MonadIO m => FileInfo -> m (Maybe MetaEntry)
toME (FileInfo -> ConduitT ByteString o (RIO env) (Maybe MetaEntry))
-> (Maybe MetaEntry -> ConduitM ByteString o (RIO env) ())
-> FileInfo
-> ConduitM ByteString o (RIO env) ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (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 :: forall (m :: * -> *). MonadIO m => FileInfo -> m (Maybe MetaEntry)
toME FileInfo
fi = do
let exc :: PantryException
exc = ArchiveLocation -> [Char] -> FileType -> PantryException
InvalidTarFileType ArchiveLocation
loc (FileInfo -> [Char]
Tar.getFileInfoPath FileInfo
fi) (FileInfo -> FileType
Tar.fileType FileInfo
fi)
Maybe METype
mmet <-
case FileInfo -> FileType
Tar.fileType FileInfo
fi of
Tar.FTSymbolicLink ByteString
bs ->
case ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
bs of
Left UnicodeException
_ -> 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 a. a -> m a
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
$ [Char] -> METype
METLink ([Char] -> METype) -> [Char] -> METype
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
text
FileType
Tar.FTNormal -> Maybe METype -> m (Maybe METype)
forall a. a -> m a
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 a. a -> m a
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 a. a -> m a
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
{ mePath :: [Char]
mePath = ShowS
removeInitialDotSlash ShowS -> (FileInfo -> [Char]) -> FileInfo -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileInfo -> [Char]
Tar.getFileInfoPath (FileInfo -> [Char]) -> FileInfo -> [Char]
forall a b. (a -> b) -> a -> b
$ 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 -> [Char]
seSource :: !FilePath
, SimpleEntry -> FileType
seType :: !FileType
}
deriving Int -> SimpleEntry -> ShowS
[SimpleEntry] -> ShowS
SimpleEntry -> [Char]
(Int -> SimpleEntry -> ShowS)
-> (SimpleEntry -> [Char])
-> ([SimpleEntry] -> ShowS)
-> Show SimpleEntry
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SimpleEntry -> ShowS
showsPrec :: Int -> SimpleEntry -> ShowS
$cshow :: SimpleEntry -> [Char]
show :: SimpleEntry -> [Char]
$cshowList :: [SimpleEntry] -> ShowS
showList :: [SimpleEntry] -> ShowS
Show
removeInitialDotSlash :: FilePath -> FilePath
removeInitialDotSlash :: ShowS
removeInitialDotSlash [Char]
filename =
[Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
filename (Maybe [Char] -> [Char]) -> Maybe [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> Maybe [Char]
forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripPrefix [Char]
"./" [Char]
filename
parseArchive ::
forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> RawPackageLocationImmutable
-> RawArchive
-> FilePath
-> RIO env (Package, CachedTree)
parseArchive :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> RawArchive -> [Char] -> RIO env (Package, CachedTree)
parseArchive RawPackageLocationImmutable
rpli RawArchive
archive [Char]
fp = do
let loc :: ArchiveLocation
loc = RawArchive -> ArchiveLocation
raLocation RawArchive
archive
archiveTypes :: [ArchiveType]
archiveTypes :: [ArchiveType]
archiveTypes = [ArchiveType
forall a. Bounded a => a
minBound .. ArchiveType
forall a. Bounded a => a
maxBound]
getFiles :: [ArchiveType] -> RIO env (ArchiveType, Map FilePath MetaEntry)
getFiles :: [ArchiveType] -> RIO env (ArchiveType, Map [Char] MetaEntry)
getFiles [] = PantryException -> RIO env (ArchiveType, Map [Char] MetaEntry)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env (ArchiveType, Map [Char] MetaEntry))
-> PantryException -> RIO env (ArchiveType, Map [Char] 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
-> [Char]
-> 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
-> [Char]
-> ArchiveType
-> a
-> (a -> MetaEntry -> ConduitT ByteString Void (RIO env) a)
-> RIO env a
foldArchive ArchiveLocation
loc [Char]
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 a. a -> ConduitT ByteString Void (RIO env) a
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 [Char] MetaEntry)
getFiles [ArchiveType]
ats
Right [MetaEntry] -> [MetaEntry]
files ->
(ArchiveType, Map [Char] MetaEntry)
-> RIO env (ArchiveType, Map [Char] MetaEntry)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ArchiveType
at, [([Char], MetaEntry)] -> Map [Char] MetaEntry
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([([Char], MetaEntry)] -> Map [Char] MetaEntry)
-> [([Char], MetaEntry)] -> Map [Char] MetaEntry
forall a b. (a -> b) -> a -> b
$ (MetaEntry -> ([Char], MetaEntry))
-> [MetaEntry] -> [([Char], MetaEntry)]
forall a b. (a -> b) -> [a] -> [b]
map (MetaEntry -> [Char]
mePath (MetaEntry -> [Char])
-> (MetaEntry -> MetaEntry) -> MetaEntry -> ([Char], MetaEntry)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
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] -> [([Char], MetaEntry)])
-> [MetaEntry] -> [([Char], MetaEntry)]
forall a b. (a -> b) -> a -> b
$ [MetaEntry] -> [MetaEntry]
files [])
(ArchiveType
at, Map [Char] MetaEntry
files) <- [ArchiveType] -> RIO env (ArchiveType, Map [Char] MetaEntry)
getFiles [ArchiveType]
archiveTypes
let toSimple :: FilePath -> MetaEntry -> Either String (Map FilePath SimpleEntry)
toSimple :: [Char] -> MetaEntry -> Either [Char] (Map [Char] SimpleEntry)
toSimple [Char]
key MetaEntry
me =
case MetaEntry -> METype
meType MetaEntry
me of
METype
METNormal ->
Map [Char] SimpleEntry -> Either [Char] (Map [Char] SimpleEntry)
forall a b. b -> Either a b
Right (Map [Char] SimpleEntry -> Either [Char] (Map [Char] SimpleEntry))
-> Map [Char] SimpleEntry -> Either [Char] (Map [Char] SimpleEntry)
forall a b. (a -> b) -> a -> b
$ [Char] -> SimpleEntry -> Map [Char] SimpleEntry
forall k a. k -> a -> Map k a
Map.singleton [Char]
key (SimpleEntry -> Map [Char] SimpleEntry)
-> SimpleEntry -> Map [Char] SimpleEntry
forall a b. (a -> b) -> a -> b
$ [Char] -> FileType -> SimpleEntry
SimpleEntry (MetaEntry -> [Char]
mePath MetaEntry
me) FileType
FTNormal
METype
METExecutable ->
Map [Char] SimpleEntry -> Either [Char] (Map [Char] SimpleEntry)
forall a b. b -> Either a b
Right (Map [Char] SimpleEntry -> Either [Char] (Map [Char] SimpleEntry))
-> Map [Char] SimpleEntry -> Either [Char] (Map [Char] SimpleEntry)
forall a b. (a -> b) -> a -> b
$ [Char] -> SimpleEntry -> Map [Char] SimpleEntry
forall k a. k -> a -> Map k a
Map.singleton [Char]
key (SimpleEntry -> Map [Char] SimpleEntry)
-> SimpleEntry -> Map [Char] SimpleEntry
forall a b. (a -> b) -> a -> b
$ [Char] -> FileType -> SimpleEntry
SimpleEntry (MetaEntry -> [Char]
mePath MetaEntry
me) FileType
FTExecutable
METLink [Char]
relDest -> do
case [Char]
relDest of
Char
'/':[Char]
_ -> [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left ([Char] -> Either [Char] ()) -> [Char] -> Either [Char] ()
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"File located at "
, ShowS
forall a. Show a => a -> [Char]
show ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ MetaEntry -> [Char]
mePath MetaEntry
me
, [Char]
" is a symbolic link to absolute path "
, [Char]
relDest
]
[Char]
_ -> () -> Either [Char] ()
forall a b. b -> Either a b
Right ()
[Char]
dest0 <-
case [Char] -> [Char] -> Either [Char] [Char]
makeTarRelative (MetaEntry -> [Char]
mePath MetaEntry
me) [Char]
relDest of
Left [Char]
e -> [Char] -> Either [Char] [Char]
forall a b. a -> Either a b
Left ([Char] -> Either [Char] [Char]) -> [Char] -> Either [Char] [Char]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"Error resolving relative path "
, [Char]
relDest
, [Char]
" from symlink at "
, MetaEntry -> [Char]
mePath MetaEntry
me
, [Char]
": "
, [Char]
e
]
Right [Char]
x -> [Char] -> Either [Char] [Char]
forall a b. b -> Either a b
Right [Char]
x
[Char]
dest <-
case [Char] -> Either [Char] [Char]
normalizeParents [Char]
dest0 of
Left [Char]
e -> [Char] -> Either [Char] [Char]
forall a b. a -> Either a b
Left ([Char] -> Either [Char] [Char]) -> [Char] -> Either [Char] [Char]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"Invalid symbolic link from "
, MetaEntry -> [Char]
mePath MetaEntry
me
, [Char]
" to "
, [Char]
relDest
, [Char]
", tried parsing "
, [Char]
dest0
, [Char]
": "
, [Char]
e
]
Right [Char]
x -> [Char] -> Either [Char] [Char]
forall a b. b -> Either a b
Right [Char]
x
case [Char] -> Map [Char] MetaEntry -> Maybe MetaEntry
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
dest Map [Char] MetaEntry
files of
Maybe MetaEntry
Nothing ->
case [Char] -> Map [Char] MetaEntry -> [([Char], MetaEntry)]
findWithPrefix [Char]
dest Map [Char] MetaEntry
files of
[] -> [Char] -> Either [Char] (Map [Char] SimpleEntry)
forall a b. a -> Either a b
Left ([Char] -> Either [Char] (Map [Char] SimpleEntry))
-> [Char] -> Either [Char] (Map [Char] SimpleEntry)
forall a b. (a -> b) -> a -> b
$
[Char]
"Symbolic link dest not found from "
[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ MetaEntry -> [Char]
mePath MetaEntry
me
[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" to "
[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
relDest
[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
", looking for "
[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
dest
[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
".\n"
[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"This may indicate that the source is a git \
\archive which uses git-annex.\n"
[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"See https://github.com/commercialhaskell/stack/issues/4579 \
\for further information."
[([Char], MetaEntry)]
pairs ->
([Map [Char] SimpleEntry] -> Map [Char] SimpleEntry)
-> Either [Char] [Map [Char] SimpleEntry]
-> Either [Char] (Map [Char] SimpleEntry)
forall a b. (a -> b) -> Either [Char] a -> Either [Char] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Map [Char] SimpleEntry] -> Map [Char] SimpleEntry
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Either [Char] [Map [Char] SimpleEntry]
-> Either [Char] (Map [Char] SimpleEntry))
-> Either [Char] [Map [Char] SimpleEntry]
-> Either [Char] (Map [Char] SimpleEntry)
forall a b. (a -> b) -> a -> b
$ [([Char], MetaEntry)]
-> (([Char], MetaEntry) -> Either [Char] (Map [Char] SimpleEntry))
-> Either [Char] [Map [Char] SimpleEntry]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [([Char], MetaEntry)]
pairs ((([Char], MetaEntry) -> Either [Char] (Map [Char] SimpleEntry))
-> Either [Char] [Map [Char] SimpleEntry])
-> (([Char], MetaEntry) -> Either [Char] (Map [Char] SimpleEntry))
-> Either [Char] [Map [Char] SimpleEntry]
forall a b. (a -> b) -> a -> b
$ \([Char]
suffix, MetaEntry
me') ->
[Char] -> MetaEntry -> Either [Char] (Map [Char] SimpleEntry)
toSimple ([Char]
key [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'/' Char -> ShowS
forall a. a -> [a] -> [a]
: [Char]
suffix) MetaEntry
me'
Just MetaEntry
me' ->
case MetaEntry -> METype
meType MetaEntry
me' of
METype
METNormal ->
Map [Char] SimpleEntry -> Either [Char] (Map [Char] SimpleEntry)
forall a b. b -> Either a b
Right (Map [Char] SimpleEntry -> Either [Char] (Map [Char] SimpleEntry))
-> Map [Char] SimpleEntry -> Either [Char] (Map [Char] SimpleEntry)
forall a b. (a -> b) -> a -> b
$ [Char] -> SimpleEntry -> Map [Char] SimpleEntry
forall k a. k -> a -> Map k a
Map.singleton [Char]
key (SimpleEntry -> Map [Char] SimpleEntry)
-> SimpleEntry -> Map [Char] SimpleEntry
forall a b. (a -> b) -> a -> b
$ [Char] -> FileType -> SimpleEntry
SimpleEntry [Char]
dest FileType
FTNormal
METype
METExecutable ->
Map [Char] SimpleEntry -> Either [Char] (Map [Char] SimpleEntry)
forall a b. b -> Either a b
Right (Map [Char] SimpleEntry -> Either [Char] (Map [Char] SimpleEntry))
-> Map [Char] SimpleEntry -> Either [Char] (Map [Char] SimpleEntry)
forall a b. (a -> b) -> a -> b
$ [Char] -> SimpleEntry -> Map [Char] SimpleEntry
forall k a. k -> a -> Map k a
Map.singleton [Char]
key (SimpleEntry -> Map [Char] SimpleEntry)
-> SimpleEntry -> Map [Char] SimpleEntry
forall a b. (a -> b) -> a -> b
$ [Char] -> FileType -> SimpleEntry
SimpleEntry [Char]
dest FileType
FTExecutable
METLink [Char]
_ ->
[Char] -> Either [Char] (Map [Char] SimpleEntry)
forall a b. a -> Either a b
Left ([Char] -> Either [Char] (Map [Char] SimpleEntry))
-> [Char] -> Either [Char] (Map [Char] SimpleEntry)
forall a b. (a -> b) -> a -> b
$
[Char]
"Symbolic link dest cannot be a symbolic link, from "
[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ MetaEntry -> [Char]
mePath MetaEntry
me
[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" to "
[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
relDest
case Map [Char] (Map [Char] SimpleEntry) -> Map [Char] SimpleEntry
forall m. Monoid m => Map [Char] m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Map [Char] (Map [Char] SimpleEntry) -> Map [Char] SimpleEntry)
-> Either [Char] (Map [Char] (Map [Char] SimpleEntry))
-> Either [Char] (Map [Char] SimpleEntry)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Char] -> MetaEntry -> Either [Char] (Map [Char] SimpleEntry))
-> Map [Char] MetaEntry
-> Either [Char] (Map [Char] (Map [Char] SimpleEntry))
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey [Char] -> MetaEntry -> Either [Char] (Map [Char] SimpleEntry)
toSimple Map [Char] MetaEntry
files of
Left [Char]
e -> 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
$ [Char] -> Text
T.pack [Char]
e
Right Map [Char] SimpleEntry
files1 -> do
let files2 :: [([Char], SimpleEntry)]
files2 = [([Char], SimpleEntry)] -> [([Char], SimpleEntry)]
forall a. [([Char], a)] -> [([Char], a)]
stripCommonPrefix ([([Char], SimpleEntry)] -> [([Char], SimpleEntry)])
-> [([Char], SimpleEntry)] -> [([Char], SimpleEntry)]
forall a b. (a -> b) -> a -> b
$ Map [Char] SimpleEntry -> [([Char], SimpleEntry)]
forall k a. Map k a -> [(k, a)]
Map.toList Map [Char] SimpleEntry
files1
files3 :: [(Text, SimpleEntry)]
files3 = Text -> [([Char], SimpleEntry)] -> [(Text, SimpleEntry)]
forall a. Text -> [([Char], a)] -> [(Text, a)]
takeSubdir (RawArchive -> Text
raSubdir RawArchive
archive) [([Char], SimpleEntry)]
files2
toSafe :: (Text, b) -> Either [Char] (SafeFilePath, b)
toSafe (Text
fp', b
a) =
case Text -> Maybe SafeFilePath
mkSafeFilePath Text
fp' of
Maybe SafeFilePath
Nothing -> [Char] -> Either [Char] (SafeFilePath, b)
forall a b. a -> Either a b
Left ([Char] -> Either [Char] (SafeFilePath, b))
-> [Char] -> Either [Char] (SafeFilePath, b)
forall a b. (a -> b) -> a -> b
$ [Char]
"Not a safe file path: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show Text
fp'
Just SafeFilePath
sfp -> (SafeFilePath, b) -> Either [Char] (SafeFilePath, b)
forall a b. b -> Either a b
Right (SafeFilePath
sfp, b
a)
case ((Text, SimpleEntry) -> Either [Char] (SafeFilePath, SimpleEntry))
-> [(Text, SimpleEntry)]
-> Either [Char] [(SafeFilePath, SimpleEntry)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Text, SimpleEntry) -> Either [Char] (SafeFilePath, SimpleEntry)
forall {b}. (Text, b) -> Either [Char] (SafeFilePath, b)
toSafe [(Text, SimpleEntry)]
files3 of
Left [Char]
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
$ [Char] -> Text
T.pack [Char]
e
Right [(SafeFilePath, SimpleEntry)]
safeFiles -> do
let toSave :: Set [Char]
toSave = [[Char]] -> Set [Char]
forall a. Ord a => [a] -> Set a
Set.fromList ([[Char]] -> Set [Char]) -> [[Char]] -> Set [Char]
forall a b. (a -> b) -> a -> b
$ ((SafeFilePath, SimpleEntry) -> [Char])
-> [(SafeFilePath, SimpleEntry)] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (SimpleEntry -> [Char]
seSource (SimpleEntry -> [Char])
-> ((SafeFilePath, SimpleEntry) -> SimpleEntry)
-> (SafeFilePath, SimpleEntry)
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SafeFilePath, SimpleEntry) -> SimpleEntry
forall a b. (a, b) -> b
snd) [(SafeFilePath, SimpleEntry)]
safeFiles
(Map [Char] (BlobKey, BlobId)
blobs :: Map FilePath (BlobKey, BlobId)) <-
ArchiveLocation
-> [Char]
-> ArchiveType
-> Map [Char] (BlobKey, BlobId)
-> (Map [Char] (BlobKey, BlobId)
-> MetaEntry
-> ConduitT
ByteString Void (RIO env) (Map [Char] (BlobKey, BlobId)))
-> RIO env (Map [Char] (BlobKey, BlobId))
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ArchiveLocation
-> [Char]
-> ArchiveType
-> a
-> (a -> MetaEntry -> ConduitT ByteString Void (RIO env) a)
-> RIO env a
foldArchive ArchiveLocation
loc [Char]
fp ArchiveType
at Map [Char] (BlobKey, BlobId)
forall a. Monoid a => a
mempty ((Map [Char] (BlobKey, BlobId)
-> MetaEntry
-> ConduitT
ByteString Void (RIO env) (Map [Char] (BlobKey, BlobId)))
-> RIO env (Map [Char] (BlobKey, BlobId)))
-> (Map [Char] (BlobKey, BlobId)
-> MetaEntry
-> ConduitT
ByteString Void (RIO env) (Map [Char] (BlobKey, BlobId)))
-> RIO env (Map [Char] (BlobKey, BlobId))
forall a b. (a -> b) -> a -> b
$ \Map [Char] (BlobKey, BlobId)
m MetaEntry
me ->
if MetaEntry -> [Char]
mePath MetaEntry
me [Char] -> Set [Char] -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set [Char]
toSave
then do
ByteString
bs <- [ByteString] -> ByteString
forall m. Monoid m => [m] -> m
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 (m :: * -> *) a.
Monad m =>
m a -> ConduitT ByteString Void m a
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 [Char] (BlobKey, BlobId)
-> ConduitT
ByteString Void (RIO env) (Map [Char] (BlobKey, BlobId))
forall a. a -> ConduitT ByteString Void (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map [Char] (BlobKey, BlobId)
-> ConduitT
ByteString Void (RIO env) (Map [Char] (BlobKey, BlobId)))
-> Map [Char] (BlobKey, BlobId)
-> ConduitT
ByteString Void (RIO env) (Map [Char] (BlobKey, BlobId))
forall a b. (a -> b) -> a -> b
$ [Char]
-> (BlobKey, BlobId)
-> Map [Char] (BlobKey, BlobId)
-> Map [Char] (BlobKey, BlobId)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (MetaEntry -> [Char]
mePath MetaEntry
me) (BlobKey
blobKey, BlobId
blobId) Map [Char] (BlobKey, BlobId)
m
else Map [Char] (BlobKey, BlobId)
-> ConduitT
ByteString Void (RIO env) (Map [Char] (BlobKey, BlobId))
forall a. a -> ConduitT ByteString Void (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map [Char] (BlobKey, BlobId)
m
CachedTree
tree :: CachedTree <-
([(SafeFilePath, (TreeEntry, BlobId))] -> CachedTree)
-> RIO env [(SafeFilePath, (TreeEntry, BlobId))]
-> RIO env CachedTree
forall a b. (a -> b) -> RIO env a -> RIO env b
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 [Char] -> Map [Char] (BlobKey, BlobId) -> Maybe (BlobKey, BlobId)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ShowS
removeInitialDotSlash ShowS -> (SimpleEntry -> [Char]) -> SimpleEntry -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleEntry -> [Char]
seSource (SimpleEntry -> [Char]) -> SimpleEntry -> [Char]
forall a b. (a -> b) -> a -> b
$ SimpleEntry
se) Map [Char] (BlobKey, BlobId)
blobs of
Maybe (BlobKey, BlobId)
Nothing ->
[Char] -> RIO env (SafeFilePath, (TreeEntry, BlobId))
forall a. HasCallStack => [Char] -> a
error ([Char] -> RIO env (SafeFilePath, (TreeEntry, BlobId)))
-> [Char] -> RIO env (SafeFilePath, (TreeEntry, BlobId))
forall a b. (a -> b) -> a -> b
$ [Char]
"Impossible: blob not found for: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ SimpleEntry -> [Char]
seSource SimpleEntry
se
Just (BlobKey
blobKey, BlobId
blobId) ->
(SafeFilePath, (TreeEntry, BlobId))
-> RIO env (SafeFilePath, (TreeEntry, BlobId))
forall a. a -> RIO env a
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 a. a -> RIO env a
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 a. a -> RIO env a
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 a. a -> RIO env a
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 a. a -> RIO env a
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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(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 a. a -> RIO env a
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 a. a -> RIO env a
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
{ phOriginal :: TreeEntry
phOriginal = TreeEntry
buildFileEntry
, phGenerated :: TreeEntry
phGenerated = TreeEntry
cabalTreeEntry
, phVersion :: Version
phVersion = Version
hpackSoftwareVersion
}
(Package, CachedTree) -> RIO env (Package, CachedTree)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Package
{ packageTreeKey :: TreeKey
packageTreeKey = TreeKey
treeKey'
, packageTree :: Tree
packageTree = CachedTree -> Tree
unCachedTree CachedTree
tree
, packageCabalEntry :: PackageCabal
packageCabalEntry = PackageCabal
packageCabal
, packageIdent :: PackageIdentifier
packageIdent = PackageIdentifier
ident
}, CachedTree
tree)
findWithPrefix :: FilePath -> Map FilePath MetaEntry -> [(FilePath, MetaEntry)]
findWithPrefix :: [Char] -> Map [Char] MetaEntry -> [([Char], MetaEntry)]
findWithPrefix [Char]
dir = (([Char], MetaEntry) -> Maybe ([Char], MetaEntry))
-> [([Char], MetaEntry)] -> [([Char], MetaEntry)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([Char], MetaEntry) -> Maybe ([Char], MetaEntry)
forall {t}. ([Char], t) -> Maybe ([Char], t)
go ([([Char], MetaEntry)] -> [([Char], MetaEntry)])
-> (Map [Char] MetaEntry -> [([Char], MetaEntry)])
-> Map [Char] MetaEntry
-> [([Char], MetaEntry)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map [Char] MetaEntry -> [([Char], MetaEntry)]
forall k a. Map k a -> [(k, a)]
Map.toList
where
prefix :: [Char]
prefix = [Char]
dir [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"/"
go :: ([Char], t) -> Maybe ([Char], t)
go ([Char]
x, t
y) = (, t
y) ([Char] -> ([Char], t)) -> Maybe [Char] -> Maybe ([Char], t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> [Char] -> Maybe [Char]
forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripPrefix [Char]
prefix [Char]
x
findCabalOrHpackFile ::
MonadThrow m
=> RawPackageLocationImmutable
-> Tree
-> m BuildFile
findCabalOrHpackFile :: forall (m :: * -> *).
MonadThrow m =>
RawPackageLocationImmutable -> Tree -> m BuildFile
findCabalOrHpackFile RawPackageLocationImmutable
loc (TreeMap Map SafeFilePath TreeEntry
m) = do
let isCabalFile :: (SafeFilePath, b) -> Bool
isCabalFile (SafeFilePath
sfp, b
_) =
let txt :: Text
txt = SafeFilePath -> Text
unSafeFilePath SafeFilePath
sfp
in Bool -> Bool
not (Text
"/" Text -> Text -> Bool
`T.isInfixOf` Text
txt) Bool -> Bool -> Bool
&& (Text
".cabal" Text -> Text -> Bool
`T.isSuffixOf` Text
txt)
isHpackFile :: (SafeFilePath, b) -> Bool
isHpackFile (SafeFilePath
sfp, b
_) =
let txt :: Text
txt = SafeFilePath -> Text
unSafeFilePath SafeFilePath
sfp
in [Char] -> Text
T.pack [Char]
Hpack.packageConfig 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 a. Maybe a -> Maybe a -> Maybe a
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 e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, 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 a. a -> m a
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 e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, 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 a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BuildFile
bfile
[BuildFile]
xs' -> PantryException -> m BuildFile
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, 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 :: forall a. [([Char], a)] -> [([Char], a)]
stripCommonPrefix [] = []
stripCommonPrefix pairs :: [([Char], a)]
pairs@(([Char]
firstFP, a
_):[([Char], a)]
_) = [([Char], a)] -> Maybe [([Char], a)] -> [([Char], a)]
forall a. a -> Maybe a -> a
fromMaybe [([Char], a)]
pairs (Maybe [([Char], a)] -> [([Char], a)])
-> Maybe [([Char], a)] -> [([Char], a)]
forall a b. (a -> b) -> a -> b
$ do
let firstDir :: [Char]
firstDir = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/') [Char]
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
$ [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
firstDir
let strip :: ([Char], t) -> Maybe ([Char], t)
strip ([Char]
fp, t
a) = (, t
a) ([Char] -> ([Char], t)) -> Maybe [Char] -> Maybe ([Char], t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> [Char] -> Maybe [Char]
forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripPrefix ([Char]
firstDir [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"/") [Char]
fp
[([Char], a)] -> [([Char], a)]
forall a. [([Char], a)] -> [([Char], a)]
stripCommonPrefix ([([Char], a)] -> [([Char], a)])
-> Maybe [([Char], a)] -> Maybe [([Char], a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (([Char], a) -> Maybe ([Char], a))
-> [([Char], a)] -> Maybe [([Char], a)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ([Char], a) -> Maybe ([Char], a)
forall {t}. ([Char], t) -> Maybe ([Char], t)
strip [([Char], a)]
pairs
takeSubdir ::
Text
-> [(FilePath, a)]
-> [(Text, a)]
takeSubdir :: forall a. Text -> [([Char], a)] -> [(Text, a)]
takeSubdir Text
subdir = (([Char], a) -> Maybe (Text, a)) -> [([Char], a)] -> [(Text, a)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((([Char], a) -> Maybe (Text, a)) -> [([Char], a)] -> [(Text, a)])
-> (([Char], a) -> Maybe (Text, a)) -> [([Char], a)] -> [(Text, a)]
forall a b. (a -> b) -> a -> b
$ \([Char]
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
$ [Char] -> Text
T.pack [Char]
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
. HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"/"
subdirs :: [Text]
subdirs = Text -> [Text]
splitDirs Text
subdir