{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Stack.Unpack
( unpackPackages
) where
import Path ( (</>), parseRelDir )
import Path.IO ( doesDirExist )
import RIO.List ( intercalate )
import qualified RIO.Map as Map
import RIO.Process ( HasProcessContext )
import qualified RIO.Set as Set
import qualified RIO.Text as T
import Stack.Prelude
data UnpackException
= UnpackDirectoryAlreadyExists (Set (Path Abs Dir))
| CouldNotParsePackageSelectors [String]
deriving (Int -> UnpackException -> ShowS
[UnpackException] -> ShowS
UnpackException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnpackException] -> ShowS
$cshowList :: [UnpackException] -> ShowS
show :: UnpackException -> String
$cshow :: UnpackException -> String
showsPrec :: Int -> UnpackException -> ShowS
$cshowsPrec :: Int -> UnpackException -> ShowS
Show, Typeable)
instance Exception UnpackException where
displayException :: UnpackException -> String
displayException (UnpackDirectoryAlreadyExists Set (Path Abs Dir)
dirs) = [String] -> String
unlines
forall a b. (a -> b) -> a -> b
$ String
"Error: [S-3515]"
forall a. a -> [a] -> [a]
: String
"Unable to unpack due to already present directories:"
forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map ((String
" " forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> String
toFilePath) (forall a. Set a -> [a]
Set.toList Set (Path Abs Dir)
dirs)
displayException (CouldNotParsePackageSelectors [String]
strs) = [String] -> String
unlines
forall a b. (a -> b) -> a -> b
$ String
"Error: [S-2628]"
forall a. a -> [a] -> [a]
: String
"The following package selectors are not valid package names or \
\identifiers:"
forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (String
"- " forall a. [a] -> [a] -> [a]
++) [String]
strs
unpackPackages
:: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> Maybe RawSnapshot
-> Path Abs Dir
-> [String]
-> RIO env ()
unpackPackages :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe RawSnapshot -> Path Abs Dir -> [String] -> RIO env ()
unpackPackages Maybe RawSnapshot
mSnapshot Path Abs Dir
dest [String]
input = do
let ([String]
errs1, ([PackageName]
names, [PackageIdentifierRevision]
pirs1)) =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map String
-> Either String (Either PackageName PackageIdentifierRevision)
parse [String]
input
[(PackageLocationImmutable, PackageIdentifier)]
locs1 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [PackageIdentifierRevision]
pirs1 forall a b. (a -> b) -> a -> b
$ \PackageIdentifierRevision
pir -> do
PackageLocationImmutable
loc <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CompletePackageLocation -> PackageLocationImmutable
cplComplete forall a b. (a -> b) -> a -> b
$ forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env CompletePackageLocation
completePackageLocation forall a b. (a -> b) -> a -> b
$ PackageIdentifierRevision
-> Maybe TreeKey -> RawPackageLocationImmutable
RPLIHackage PackageIdentifierRevision
pir forall a. Maybe a
Nothing
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageLocationImmutable
loc, PackageLocationImmutable -> PackageIdentifier
packageLocationIdent PackageLocationImmutable
loc)
([String]
errs2, [(PackageLocationImmutable, PackageIdentifier)]
locs2) <- forall a b. [Either a b] -> ([a], [b])
partitionEithers forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse PackageName
-> RIO
env (Either String (PackageLocationImmutable, PackageIdentifier))
toLoc [PackageName]
names
case [String]
errs1 forall a. [a] -> [a] -> [a]
++ [String]
errs2 of
[] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
[String]
errs -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ [String] -> UnpackException
CouldNotParsePackageSelectors [String]
errs
Map PackageLocationImmutable (Path Abs Dir)
locs <- forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
(\(PackageLocationImmutable
pir, PackageIdentifier
ident) -> do
Path Rel Dir
suffix <- forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> String
packageIdentifierString PackageIdentifier
ident
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageLocationImmutable
pir, Path Abs Dir
dest forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
suffix)
)
([(PackageLocationImmutable, PackageIdentifier)]
locs1 forall a. [a] -> [a] -> [a]
++ [(PackageLocationImmutable, PackageIdentifier)]
locs2)
[Path Abs Dir]
alreadyUnpacked <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems Map PackageLocationImmutable (Path Abs Dir)
locs
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Path Abs Dir]
alreadyUnpacked) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Set (Path Abs Dir) -> UnpackException
UnpackDirectoryAlreadyExists forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [Path Abs Dir]
alreadyUnpacked
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [(k, a)]
Map.toList Map PackageLocationImmutable (Path Abs Dir)
locs) forall a b. (a -> b) -> a -> b
$ \(PackageLocationImmutable
loc, Path Abs Dir
dest') -> do
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir -> PackageLocationImmutable -> RIO env ()
unpackPackageLocation Path Abs Dir
dest' PackageLocationImmutable
loc
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$
Utf8Builder
"Unpacked " forall a. Semigroup a => a -> a -> a
<>
forall a. Display a => a -> Utf8Builder
display PackageLocationImmutable
loc forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
" to " forall a. Semigroup a => a -> a -> a
<>
forall a. IsString a => String -> a
fromString (forall b t. Path b t -> String
toFilePath Path Abs Dir
dest')
where
toLoc :: PackageName
-> RIO
env (Either String (PackageLocationImmutable, PackageIdentifier))
toLoc | Just RawSnapshot
snapshot <- Maybe RawSnapshot
mSnapshot = RawSnapshot
-> PackageName
-> RIO
env (Either String (PackageLocationImmutable, PackageIdentifier))
toLocSnapshot RawSnapshot
snapshot
| Bool
otherwise = PackageName
-> RIO
env (Either String (PackageLocationImmutable, PackageIdentifier))
toLocNoSnapshot
toLocNoSnapshot :: PackageName -> RIO env (Either String (PackageLocationImmutable, PackageIdentifier))
toLocNoSnapshot :: PackageName
-> RIO
env (Either String (PackageLocationImmutable, PackageIdentifier))
toLocNoSnapshot PackageName
name = do
Maybe PackageLocationImmutable
mloc1 <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RequireHackageIndex
-> PackageName
-> UsePreferredVersions
-> RIO env (Maybe PackageLocationImmutable)
getLatestHackageLocation RequireHackageIndex
YesRequireHackageIndex PackageName
name UsePreferredVersions
UsePreferredVersions
Maybe PackageLocationImmutable
mloc <-
case Maybe PackageLocationImmutable
mloc1 of
Just PackageLocationImmutable
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe PackageLocationImmutable
mloc1
Maybe PackageLocationImmutable
Nothing -> do
DidUpdateOccur
updated <- forall env.
(HasPantryConfig env, HasLogFunc env) =>
Maybe Utf8Builder -> RIO env DidUpdateOccur
updateHackageIndex forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Could not find package " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (PackageName -> String
packageNameString PackageName
name) forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", updating"
case DidUpdateOccur
updated of
DidUpdateOccur
UpdateOccurred -> forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RequireHackageIndex
-> PackageName
-> UsePreferredVersions
-> RIO env (Maybe PackageLocationImmutable)
getLatestHackageLocation RequireHackageIndex
YesRequireHackageIndex PackageName
name UsePreferredVersions
UsePreferredVersions
DidUpdateOccur
NoUpdateOccurred -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
case Maybe PackageLocationImmutable
mloc of
Maybe PackageLocationImmutable
Nothing -> do
[PackageName]
candidates <- forall env.
(HasPantryConfig env, HasLogFunc env) =>
PackageName -> RIO env [PackageName]
getHackageTypoCorrections PackageName
name
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ String
"Could not find package "
, PackageName -> String
packageNameString PackageName
name
, String
" on Hackage"
, if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
candidates
then String
""
else String
". Perhaps you meant: " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a b. (a -> b) -> [a] -> [b]
map PackageName -> String
packageNameString [PackageName]
candidates)
]
Just PackageLocationImmutable
loc -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (PackageLocationImmutable
loc, PackageLocationImmutable -> PackageIdentifier
packageLocationIdent PackageLocationImmutable
loc)
toLocSnapshot :: RawSnapshot -> PackageName -> RIO env (Either String (PackageLocationImmutable, PackageIdentifier))
toLocSnapshot :: RawSnapshot
-> PackageName
-> RIO
env (Either String (PackageLocationImmutable, PackageIdentifier))
toLocSnapshot RawSnapshot
snapshot PackageName
name =
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name (RawSnapshot -> Map PackageName RawSnapshotPackage
rsPackages RawSnapshot
snapshot) of
Maybe RawSnapshotPackage
Nothing ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Package does not appear in snapshot: " forall a. [a] -> [a] -> [a]
++ PackageName -> String
packageNameString PackageName
name
Just RawSnapshotPackage
sp -> do
PackageLocationImmutable
loc <- CompletePackageLocation -> PackageLocationImmutable
cplComplete forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env CompletePackageLocation
completePackageLocation (RawSnapshotPackage -> RawPackageLocationImmutable
rspLocation RawSnapshotPackage
sp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (PackageLocationImmutable
loc, PackageLocationImmutable -> PackageIdentifier
packageLocationIdent PackageLocationImmutable
loc)
parse :: String
-> Either String (Either PackageName PackageIdentifierRevision)
parse String
s =
case String -> Maybe PackageName
parsePackageName (Text -> String
T.unpack Text
t) of
Just PackageName
x -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left PackageName
x
Maybe PackageName
Nothing ->
case Text -> Either PantryException PackageIdentifierRevision
parsePackageIdentifierRevision Text
t of
Right PackageIdentifierRevision
x -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right PackageIdentifierRevision
x
Left PantryException
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Could not parse as package name or identifier: " forall a. [a] -> [a] -> [a]
++ String
s
where
t :: Text
t = String -> Text
T.pack String
s