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