content: {-# LANGUAGE NoImplicitPrelude   #-}
  {-# LANGUAGE NoFieldSelectors    #-}
  {-# LANGUAGE OverloadedRecordDot #-}
  {-# LANGUAGE OverloadedStrings   #-}
  
  {-|
  Module      : Stack.Unpack
  Description : Functions related to Stack's @unpack@ command.
  License     : BSD-3-Clause
  
  Functions related to Stack's @unpack@ command.
  -}
  
  module Stack.Unpack
    ( UnpackOpts (..)
    , UnpackTarget
    , unpackCmd
    , unpackPackages
    ) where
  
  import           Data.List.Extra ( notNull )
  import           Path ( SomeBase (..), (</>), parseRelDir )
  import           Path.IO ( doesDirExist, getCurrentDir )
  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 ( getRawSnapshot )
  import           Stack.Constants ( relDirRoot )
  import           Stack.Prelude
  import           Stack.Runners ( ShouldReexec (..), withConfig )
  import           Stack.Types.Config ( Config (..), HasConfig, configL )
  import           Stack.Types.Runner ( Runner )
  
  -- | Type representing \'pretty\' exceptions thrown by functions exported by the
  -- "Stack.Unpack" module.
  data UnpackPrettyException
    = UnpackDirectoryAlreadyExists (Set (Path Abs Dir))
    | CouldNotParsePackageSelectors [StyleDoc]
    | PackageCandidatesRequireVersions [PackageName]
    | PackageLocationInvalid PackageIdentifierRevision
    deriving Show
  
  instance Pretty UnpackPrettyException where
    pretty (UnpackDirectoryAlreadyExists dirs) =
      "[S-3515]"
      <> line
      <> flow "Stack was unable to unpack due to directories already being \
              \present:"
      <> line
      <> bulletedList (map pretty $ Set.toList dirs)
    pretty (CouldNotParsePackageSelectors errs) =
      "[S-2628]"
      <> line
      <> flow "The following package selectors are not valid package names or \
              \identifiers:"
      <> line
      <> bulletedList errs
    pretty (PackageCandidatesRequireVersions names) =
      "[S-6114]"
      <> line
      <> flow "Package candidates to unpack cannot be identified by name only. \
              \The following do not specify a version:"
      <> line
      <> bulletedList (map fromPackageName names)
    pretty (PackageLocationInvalid pir) =
      "[S-5170]"
      <> line
      <> fillSep
           [ flow "While trying to unpack"
           , style Target (fromString $ T.unpack $ textDisplay pir) <> ","
           , flow "Stack encountered an error."
           ]
  
  instance Exception UnpackPrettyException
  
  -- | Type synonymn representing packages to be unpacked by the @stack unpack@
  -- command, identified either by name only or by an identifier (including
  -- Hackage revision).
  type UnpackTarget = Either PackageName PackageIdentifierRevision
  
  -- | Type representing options for the @stack unpack@ command.
  data UnpackOpts = UnpackOpts
    { targets :: [UnpackTarget]
      -- ^ The packages or package candidates to be unpacked.
    , areCandidates :: Bool
      -- ^ Whether the targets are Hackage package candidates.
    , dest :: Maybe (SomeBase Dir)
      -- ^ The optional directory into which a target will be unpacked into a
      -- subdirectory.
    }
  
  -- | Function underlying the @stack unpack@ command. Unpack packages or package
  -- candidates to the filesystem.
  unpackCmd ::
       UnpackOpts
    -> RIO Runner ()
  unpackCmd (UnpackOpts targets areCandidates Nothing) =
    unpackCmd (UnpackOpts targets areCandidates (Just $ Rel relDirRoot))
  unpackCmd (UnpackOpts targets areCandidates (Just dstPath)) =
    withConfig NoReexec $ do
      mSnapshot <- getRawSnapshot
      dstPath' <- case dstPath of
        Abs path -> pure path
        Rel path -> do
          wd <- getCurrentDir
          pure $ wd </> path
      unpackPackages mSnapshot dstPath' targets areCandidates
  
  -- | Intended to work for the command line command.
  unpackPackages ::
       forall env.
         (HasConfig env, HasPantryConfig env, HasProcessContext env, HasTerm env)
    => Maybe RawSnapshot -- ^ When looking up by name, take from this build plan.
    -> Path Abs Dir -- ^ Destination.
    -> [UnpackTarget]
    -> Bool
       -- ^ Whether the targets are package candidates.
    -> RIO env ()
  unpackPackages mSnapshot dest targets areCandidates = do
    let (names, pirs) = partitionEithers targets
        pisWithRevisions = any hasRevision pirs
        hasRevision (PackageIdentifierRevision _ _ CFILatest) = False
        hasRevision _ = True
    when (areCandidates && notNull names) $
      prettyThrowIO $ PackageCandidatesRequireVersions names
    when (areCandidates && pisWithRevisions) $
      prettyWarn $
           flow "Package revisions are not meaningful for package candidates and \
                \will be ignored."
        <> line
    locs1 <- forM pirs $ \pir -> do
      hackageBaseUrl <- view $ configL . to (.hackageBaseUrl)
      let rpli = if areCandidates
            then
              let -- Ignoring revisions for package candidates.
                  PackageIdentifierRevision candidateName candidateVersion _ = pir
                  candidatePkgId =
                    PackageIdentifier candidateName candidateVersion
                  candidatePkgIdText =
                    T.pack $ packageIdentifierString candidatePkgId
                  candidateUrl =
                       hackageBaseUrl
                    <> "package/"
                    <> candidatePkgIdText
                    <> "/candidate/"
                    <> candidatePkgIdText
                    <> ".tar.gz"
                  candidateLoc = ALUrl candidateUrl
                  candidateArchive = RawArchive candidateLoc Nothing Nothing ""
                  candidateMetadata = RawPackageMetadata Nothing Nothing Nothing
              in RPLIArchive candidateArchive candidateMetadata
            else RPLIHackage pir Nothing
      loc <- cplComplete <$> completePackageLocation rpli
        `catch` \(_ :: SomeException) -> prettyThrowIO $ PackageLocationInvalid pir
      pure (loc, packageLocationIdent loc)
    (errs, locs2) <- partitionEithers <$> traverse toLoc names
    unless (null errs) $ prettyThrowM $ CouldNotParsePackageSelectors errs
    locs <- Map.fromList <$> mapM
      (\(pir, ident) -> do
          suffix <- parseRelDir $ packageIdentifierString ident
          pure (pir, dest </> suffix)
      )
      (locs1 ++ locs2)
  
    alreadyUnpacked <- filterM doesDirExist $ Map.elems locs
  
    unless (null alreadyUnpacked) $
      prettyThrowM $ UnpackDirectoryAlreadyExists $ Set.fromList alreadyUnpacked
  
    forM_ (Map.toList locs) $ \(loc, dest') -> do
      unpackPackageLocation dest' loc
      prettyInfoL
        [ "Unpacked"
        , fromString $ T.unpack $ textDisplay loc
        , "to"
        , pretty dest' <> "."
        ]
   where
    toLoc name | Just snapshot <- mSnapshot = toLocSnapshot snapshot name
               | otherwise = do
                   void $ updateHackageIndex $ Just "Updating the package index."
                   toLocNoSnapshot name
  
    toLocNoSnapshot ::
         PackageName
      -> RIO env (Either StyleDoc (PackageLocationImmutable, PackageIdentifier))
    toLocNoSnapshot name = do
      mLoc <- getLatestHackageLocation
        YesRequireHackageIndex
        name
        UsePreferredVersions
      case mLoc of
        Nothing -> do
          candidates <- getHackageTypoCorrections name
          pure $ Left $ fillSep
            [ flow "Could not find package"
            , style Current (fromPackageName name)
            , flow "on Hackage."
            , if null candidates
                then mempty
                else fillSep $
                    flow "Perhaps you meant one of:"
                  : mkNarrativeList (Just Good) False
                      (map fromPackageName candidates :: [StyleDoc])
            ]
        Just loc -> pure $ Right (loc, packageLocationIdent loc)
  
    toLocSnapshot ::
         RawSnapshot
      -> PackageName
      -> RIO env (Either StyleDoc (PackageLocationImmutable, PackageIdentifier))
    toLocSnapshot snapshot name =
      case Map.lookup name (rsPackages snapshot) of
        Nothing ->
          pure $ Left $ fillSep
            [ flow "Package does not appear in snapshot:"
            , style Current (fromPackageName name) <> "."
            ]
        Just sp -> do
          loc <- cplComplete <$> completePackageLocation (rspLocation sp)
          pure $ Right (loc, packageLocationIdent loc)
  