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

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

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

import qualified Codec.Archive.Zip as Zip
import           Conduit
                   ( 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 =
  -- TODO be more efficient, group together shared archives

  [(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 -- ^ for exceptions

  -> RawArchive
  -> RawPackageMetadata
  -> RIO env TreeKey
getArchiveKey :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> RawArchive -> RawPackageMetadata -> RIO env TreeKey
getArchiveKey RawPackageLocationImmutable
rpli RawArchive
archive RawPackageMetadata
rpm =
  Package -> TreeKey
packageTreeKey (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 -- potential optimization


thd4 :: (a, b, c, d) -> c
thd4 :: forall a b c d. (a, b, c, d) -> c
thd4 (a
_, b
_, c
z, d
_) = c
z

getArchivePackage ::
     forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env, HasCallStack)
  => RawPackageLocationImmutable -- ^ for exceptions

  -> RawArchive
  -> RawPackageMetadata
  -> RIO env Package
getArchivePackage :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env,
 HasCallStack) =>
RawPackageLocationImmutable
-> RawArchive -> RawPackageMetadata -> RIO env Package
getArchivePackage RawPackageLocationImmutable
rpli RawArchive
archive RawPackageMetadata
rpm = (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 -- ^ for exceptions

  -> RawArchive
  -> RawPackageMetadata
  -> RIO env (SHA256, FileSize, Package, CachedTree)
getArchive :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env,
 HasCallStack) =>
RawPackageLocationImmutable
-> RawArchive
-> RawPackageMetadata
-> RIO env (SHA256, FileSize, Package, CachedTree)
getArchive RawPackageLocationImmutable
rpli RawArchive
archive RawPackageMetadata
rpm = do
  -- Check if the value is in the cache, and use it if possible

  Maybe (SHA256, FileSize, Package)
mcached <- 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
  -- Ensure that all of the blobs referenced exist in the cache

  -- See: https://github.com/commercialhaskell/pantry/issues/27

  Maybe CachedTree
mtree <-
    case Maybe (SHA256, FileSize, Package)
mcached of
      Maybe (SHA256, FileSize, Package)
Nothing -> 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)
      -- Not in the archive. Load the archive. Completely ignore the

      -- PackageMetadata for now, we'll check that the Package info matches

      -- next.

      (Maybe (SHA256, FileSize, Package), Maybe CachedTree)
_ -> 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
        -- Storing in the cache exclusively uses information we have about the

        -- archive itself, not metadata from the user.

        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 () -- TODO cache local as well


loadCache ::
     forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => RawPackageLocationImmutable
  -> RawArchive
  -> RIO env (Maybe (SHA256, FileSize, Package))
loadCache :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> RawArchive -> RIO env (Maybe (SHA256, FileSize, Package))
loadCache RawPackageLocationImmutable
rpli RawArchive
archive =
  case ArchiveLocation
loc of
    ALFilePath ResolvedPath File
_ -> 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 -- TODO can we do something intelligent here?

    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
                -- Only debug level, let lock files solve this

                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
                  -- Only debug level, let lock files solve this

                  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
                    -- This is an actual warning, since we have a concrete

                    -- mismatch

                    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

-- ensure name, version, etc are correct

checkPackageMetadata ::
     RawPackageLocationImmutable
  -> RawPackageMetadata
  -> Package
  -> Either PantryException Package
checkPackageMetadata :: RawPackageLocationImmutable
-> RawPackageMetadata -> Package -> Either PantryException Package
checkPackageMetadata RawPackageLocationImmutable
pl RawPackageMetadata
pm Package
pa = do
  let
      err :: PantryException
err = RawPackageLocationImmutable
-> RawPackageMetadata
-> Maybe TreeKey
-> PackageIdentifier
-> PantryException
MismatchedPackageMetadata
              RawPackageLocationImmutable
pl
              RawPackageMetadata
pm
              (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

-- | Provide a local file with the contents of the archive, regardless of where

-- it comes from. If not downloading, checks that the archive file exists.

-- Performs SHA256 and file size validation.

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 -- ^ for error reporting

  -> FilePath
  -> ArchiveType
  -> a
  -> (a -> MetaEntry -> ConduitT ByteString Void (RIO env) a)
  -> RIO env a
foldArchive :: forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ArchiveLocation
-> [Char]
-> ArchiveType
-> a
-> (a -> MetaEntry -> ConduitT ByteString Void (RIO env) a)
-> RIO env a
foldArchive ArchiveLocation
loc [Char]
fp ArchiveType
ATTarGz a
accum a -> MetaEntry -> ConduitT ByteString Void (RIO env) a
f =
  [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
  -- We're entering lazy I/O land thanks to zip-archive.

  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 -- ^ for exceptions

  -> a
  -> (a -> MetaEntry -> ConduitT ByteString o (RIO env) a)
  -> ConduitT ByteString o (RIO env) a
foldTar :: forall env a o.
(HasPantryConfig env, HasLogFunc env) =>
ArchiveLocation
-> a
-> (a -> MetaEntry -> ConduitT ByteString o (RIO env) a)
-> ConduitT ByteString o (RIO env) a
foldTar ArchiveLocation
loc a
accum0 a -> MetaEntry -> ConduitT ByteString o (RIO env) a
f = do
  IORef a
ref <- 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

-- | Attempt to parse the contents of the given archive in the given subdir into

-- a 'Tree'. This will not consult any caches. It will ensure that:

--

-- * The cabal file exists

--

-- * The cabal file can be parsed

--

-- * The name inside the cabal file matches the name of the cabal file itself

parseArchive ::
     forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => RawPackageLocationImmutable
  -> RawArchive
  -> FilePath -- ^ file holding the archive

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

          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
            -- Check if it's a symlink to a file

            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 ->
                -- Check if it's a symlink to a directory

                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))
          -- parse the cabal file and ensure it has the right name

          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 ()
          -- It's good! Store the tree, let's bounce

          (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)

-- | Find all of the files in the Map with the given directory as a prefix.

-- Directory is given without trailing slash. Returns the suffix after stripping

-- the given prefix.

findWithPrefix :: FilePath -> Map FilePath MetaEntry -> [(FilePath, MetaEntry)]
findWithPrefix :: [Char] -> Map [Char] MetaEntry -> [([Char], MetaEntry)]
findWithPrefix [Char]
dir = (([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 -- ^ for exceptions

  -> Tree
  -> m BuildFile
findCabalOrHpackFile :: forall (m :: * -> *).
MonadThrow m =>
RawPackageLocationImmutable -> Tree -> m BuildFile
findCabalOrHpackFile RawPackageLocationImmutable
loc (TreeMap Map SafeFilePath TreeEntry
m) = do
  let isCabalFile :: (SafeFilePath, b) -> Bool
isCabalFile (SafeFilePath
sfp, b
_) =
        let txt :: Text
txt = SafeFilePath -> Text
unSafeFilePath SafeFilePath
sfp
         in Bool -> Bool
not (Text
"/" Text -> Text -> Bool
`T.isInfixOf` Text
txt) Bool -> Bool -> Bool
&& (Text
".cabal" Text -> Text -> Bool
`T.isSuffixOf` Text
txt)
      isHpackFile :: (SafeFilePath, b) -> Bool
isHpackFile (SafeFilePath
sfp, b
_) =
        let txt :: Text
txt = SafeFilePath -> Text
unSafeFilePath SafeFilePath
sfp
         in [Char] -> Text
T.pack [Char]
Hpack.packageConfig 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'

-- | If all files have a shared prefix, strip it off

stripCommonPrefix :: [(FilePath, a)] -> [(FilePath, a)]
stripCommonPrefix :: forall a. [([Char], a)] -> [([Char], a)]
stripCommonPrefix [] = []
stripCommonPrefix pairs :: [([Char], a)]
pairs@(([Char]
firstFP, a
_):[([Char], a)]
_) = [([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

-- | Take us down to the specified subdirectory

takeSubdir ::
     Text -- ^ subdir

  -> [(FilePath, a)] -- ^ files after stripping common prefix

  -> [(Text, a)]
takeSubdir :: forall a. Text -> [([Char], a)] -> [(Text, a)]
takeSubdir Text
subdir = (([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