{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE OverloadedStrings   #-}

-- | Functions related to Stack's @unpack@ command.

module Stack.Unpack
  ( unpackCmd
  , unpackPackages
  ) where

import           Path ( (</>), parseRelDir )
import           Path.IO ( doesDirExist, resolveDir' )
import           Pantry ( loadSnapshot )
import qualified RIO.Map as Map
import           RIO.Process ( HasProcessContext )
import qualified RIO.Set as Set
import qualified RIO.Text as T
import           Stack.Config ( makeConcreteResolver )
import           Stack.Prelude
import           Stack.Runners ( ShouldReexec (..), withConfig )
import           Stack.Types.GlobalOpts ( GlobalOpts (..) )
import           Stack.Types.Runner ( Runner, globalOptsL )

-- | Type representing \'pretty\' exceptions thrown by functions exported by the

-- "Stack.Unpack" module.

data UnpackPrettyException
  = UnpackDirectoryAlreadyExists (Set (Path Abs Dir))
  | CouldNotParsePackageSelectors [StyleDoc]
  deriving (Int -> UnpackPrettyException -> ShowS
[UnpackPrettyException] -> ShowS
UnpackPrettyException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnpackPrettyException] -> ShowS
$cshowList :: [UnpackPrettyException] -> ShowS
show :: UnpackPrettyException -> String
$cshow :: UnpackPrettyException -> String
showsPrec :: Int -> UnpackPrettyException -> ShowS
$cshowsPrec :: Int -> UnpackPrettyException -> ShowS
Show, Typeable)

instance Pretty UnpackPrettyException where
  pretty :: UnpackPrettyException -> StyleDoc
pretty (UnpackDirectoryAlreadyExists Set (Path Abs Dir)
dirs) =
    StyleDoc
"[S-3515]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"Stack was unable to unpack due to directories already being \
            \present:"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> StyleDoc
pretty forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set (Path Abs Dir)
dirs)
  pretty (CouldNotParsePackageSelectors [StyleDoc]
errs) =
    StyleDoc
"[S-2628]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"The following package selectors are not valid package names or \
            \identifiers:"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList [StyleDoc]
errs

instance Exception UnpackPrettyException

-- | Function underlying the @stack unpack@ command. Unpack packages to the

-- filesystem.

unpackCmd ::
     ([String], Maybe Text)
     -- ^ A pair of a list of names or identifiers and an optional destination

     -- path.

  -> RIO Runner ()
unpackCmd :: ([String], Maybe Text) -> RIO Runner ()
unpackCmd ([String]
names, Maybe Text
Nothing) = ([String], Maybe Text) -> RIO Runner ()
unpackCmd ([String]
names, forall a. a -> Maybe a
Just Text
".")
unpackCmd ([String]
names, Just Text
dstPath) = forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
NoReexec forall a b. (a -> b) -> a -> b
$ do
  Maybe AbstractResolver
mresolver <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasRunner env => Lens' env GlobalOpts
globalOptsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to GlobalOpts -> Maybe AbstractResolver
globalResolver
  Maybe RawSnapshot
mSnapshot <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe AbstractResolver
mresolver forall a b. (a -> b) -> a -> b
$ \AbstractResolver
resolver -> do
    RawSnapshotLocation
concrete <- forall env.
HasConfig env =>
AbstractResolver -> RIO env RawSnapshotLocation
makeConcreteResolver AbstractResolver
resolver
    SnapshotLocation
loc <- forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawSnapshotLocation -> RIO env SnapshotLocation
completeSnapshotLocation RawSnapshotLocation
concrete
    forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
SnapshotLocation -> RIO env RawSnapshot
loadSnapshot SnapshotLocation
loc
  Path Abs Dir
dstPath' <- forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
resolveDir' forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
dstPath
  forall env.
(HasPantryConfig env, HasProcessContext env, HasTerm env) =>
Maybe RawSnapshot -> Path Abs Dir -> [String] -> RIO env ()
unpackPackages Maybe RawSnapshot
mSnapshot Path Abs Dir
dstPath' [String]
names

-- | Intended to work for the command line command.

unpackPackages ::
     forall env. (HasPantryConfig env, HasProcessContext env, HasTerm env)
  => Maybe RawSnapshot -- ^ When looking up by name, take from this build plan.

  -> Path Abs Dir -- ^ Destination.

  -> [String] -- ^ Names or identifiers.

  -> RIO env ()
unpackPackages :: forall env.
(HasPantryConfig env, HasProcessContext env, HasTerm env) =>
Maybe RawSnapshot -> Path Abs Dir -> [String] -> RIO env ()
unpackPackages Maybe RawSnapshot
mSnapshot Path Abs Dir
dest [String]
input = do
  let ([StyleDoc]
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 StyleDoc (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)
  ([StyleDoc]
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 StyleDoc (PackageLocationImmutable, PackageIdentifier))
toLoc [PackageName]
names
  case [StyleDoc]
errs1 forall a. [a] -> [a] -> [a]
++ [StyleDoc]
errs2 of
    [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [StyleDoc]
errs -> forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> UnpackPrettyException
CouldNotParsePackageSelectors [StyleDoc]
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 e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM forall a b. (a -> b) -> a -> b
$ Set (Path Abs Dir) -> UnpackPrettyException
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 env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
      [ StyleDoc
"Unpacked"
      , forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay PackageLocationImmutable
loc
      , StyleDoc
"to"
      , forall a. Pretty a => a -> StyleDoc
pretty Path Abs Dir
dest' forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
      ]
 where
  toLoc :: PackageName
-> RIO
     env (Either StyleDoc (PackageLocationImmutable, PackageIdentifier))
toLoc | Just RawSnapshot
snapshot <- Maybe RawSnapshot
mSnapshot = RawSnapshot
-> PackageName
-> RIO
     env (Either StyleDoc (PackageLocationImmutable, PackageIdentifier))
toLocSnapshot RawSnapshot
snapshot
        | Bool
otherwise = PackageName
-> RIO
     env (Either StyleDoc (PackageLocationImmutable, PackageIdentifier))
toLocNoSnapshot

  toLocNoSnapshot ::
       PackageName
    -> RIO env (Either StyleDoc (PackageLocationImmutable, PackageIdentifier))
  toLocNoSnapshot :: PackageName
-> RIO
     env (Either StyleDoc (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
$ [StyleDoc] -> StyleDoc
fillSep
          [ String -> StyleDoc
flow String
"Could not find package"
          , Style -> StyleDoc -> StyleDoc
style Style
Current (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
name)
          , String -> StyleDoc
flow String
"on Hackage."
          , if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
candidates
              then forall a. Monoid a => a
mempty
              else [StyleDoc] -> StyleDoc
fillSep forall a b. (a -> b) -> a -> b
$
                  String -> StyleDoc
flow String
"Perhaps you meant one of:"
                forall a. a -> [a] -> [a]
: forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (forall a. a -> Maybe a
Just Style
Good) Bool
False
                    (forall a b. (a -> b) -> [a] -> [b]
map (forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString) [PackageName]
candidates :: [StyleDoc])
          ]
      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 StyleDoc (PackageLocationImmutable, PackageIdentifier))
  toLocSnapshot :: RawSnapshot
-> PackageName
-> RIO
     env (Either StyleDoc (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
$ [StyleDoc] -> StyleDoc
fillSep
          [ String -> StyleDoc
flow String
"Package does not appear in snapshot:"
          , Style -> StyleDoc -> StyleDoc
style Style
Current (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
name) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
          ]
      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)

  -- Possible future enhancement: parse names as name + version range

  parse :: String
-> Either StyleDoc (Either PackageName PackageIdentifierRevision)
parse String
s =
    case String -> Maybe PackageName
parsePackageName String
s 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 (String -> Text
T.pack String
s) 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
$ [StyleDoc] -> StyleDoc
fillSep
            [ String -> StyleDoc
flow String
"Could not parse as package name or identifier:"
            , Style -> StyleDoc -> StyleDoc
style Style
Current (forall a. IsString a => String -> a
fromString String
s) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
            ]