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

-- | Types and functions related to Stack's @new@ command.

module Stack.New
    ( NewOpts (..)
    , TemplateName
    , newCmd
    , new
    ) where

import           Control.Monad.Trans.Writer.Strict ( execWriterT )
import           Data.Aeson as A
import qualified Data.Aeson.KeyMap as KeyMap
import qualified Data.ByteString.Base64 as B64
import           Data.ByteString.Builder ( lazyByteString )
import qualified Data.ByteString.Lazy as LB
import           Data.Conduit ( yield )
import qualified Data.List as L
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import           Data.Time.Calendar ( toGregorian )
import           Data.Time.Clock ( getCurrentTime, utctDay )
import           Network.HTTP.Client ( applyBasicAuth )
import           Network.HTTP.StackClient
                   ( HttpException (..), HttpExceptionContent (..)
                   , Response (..), VerifiedDownloadException (..)
                   , mkDownloadRequest, notFound404, parseRequest
                   , setForceDownload, setRequestCheckStatus
                   , verifiedDownloadWithProgress
                   )
import           Path ( (</>), dirname, parent, parseRelDir, parseRelFile )
import           Path.IO
                   ( doesDirExist, doesFileExist, ensureDir, getCurrentDir )
import           RIO.Process ( proc, runProcess_, withWorkingDir )
import           Stack.Constants
                   ( altGitHubTokenEnvVar, backupUrlRelPath, gitHubBasicAuthType
                   , gitHubTokenEnvVar, stackDotYaml, wiredInPackages
                   )
import           Stack.Constants.Config ( templatesDir )
import           Stack.Init ( InitOpts (..), initProject )
import           Stack.Prelude
import           Stack.Runners
                   ( ShouldReexec (..), withConfig, withGlobalProject )
import           Stack.Types.Config ( Config (..), HasConfig (..) )
import           Stack.Types.GlobalOpts ( GlobalOpts (..) )
import           Stack.Types.Runner ( Runner, globalOptsL )
import           Stack.Types.SCM ( SCM (..) )
import           Stack.Types.TemplateName
                   ( RepoService (..), RepoTemplatePath (..), TemplateName
                   , TemplatePath (..), defaultTemplateName
                   , parseRepoPathWithService, templateName, templatePath
                   )
import           System.Environment ( lookupEnv )
import qualified Text.Mustache as Mustache
import qualified Text.Mustache.Render as Mustache
import           Text.ProjectTemplate
                   ( ProjectTemplateException, receiveMem, unpackTemplate )

--------------------------------------------------------------------------------

-- Exceptions


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

-- "Stack.New" module.

data NewPrettyException
  = ProjectDirAlreadyExists !String !(Path Abs Dir)
  | DownloadTemplateFailed !Text !String !VerifiedDownloadException
  | forall b. LoadTemplateFailed !TemplateName !(Path b File)
  | forall b. ExtractTemplateFailed !TemplateName !(Path b File) !String
  | TemplateInvalid !TemplateName !StyleDoc
  | MagicPackageNameInvalid !String
  | AttemptedOverwrites !Text ![Path Abs File]
  deriving Typeable

deriving instance Show NewPrettyException

instance Pretty NewPrettyException where
  pretty :: NewPrettyException -> StyleDoc
pretty (ProjectDirAlreadyExists String
name Path Abs Dir
path) =
    StyleDoc
"[S-2135]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ String -> StyleDoc
flow String
"Stack failed to create a new directory for project"
         , Style -> StyleDoc -> StyleDoc
style Style
Current (String -> StyleDoc
forall a. IsString a => String -> a
fromString String
name) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
         , String -> StyleDoc
flow String
"as the directory"
         , Path Abs Dir -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs Dir
path
         , String -> StyleDoc
flow String
"already exists."
         ]
  pretty (DownloadTemplateFailed Text
name String
url VerifiedDownloadException
err) =
    StyleDoc
"[S-1688]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ String -> StyleDoc
flow String
"Stack failed to download the template"
         , Style -> StyleDoc -> StyleDoc
style Style
Current (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> (Text -> String) -> Text -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> StyleDoc) -> Text -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text
name)
         , StyleDoc
"from"
         , Style -> StyleDoc -> StyleDoc
style Style
Url (String -> StyleDoc
forall a. IsString a => String -> a
fromString String
url) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         ]
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> ( if Bool
isNotFound
            then    String -> StyleDoc
flow String
"Please check that the template exists at that \
                         \location."
                 StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
            else StyleDoc
forall a. Monoid a => a
mempty
       )
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ String -> StyleDoc
flow String
"While downloading, Stack encountered"
         , StyleDoc
msg
         ]
   where
    (StyleDoc
msg, Bool
isNotFound) = case VerifiedDownloadException
err of
      DownloadHttpError (HttpExceptionRequest Request
req HttpExceptionContent
content) ->
        let msg' :: StyleDoc
msg' =    String -> StyleDoc
flow String
"an HTTP error. Stack made the request:"
                   StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
                   StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
string (Request -> String
forall a. Show a => a -> String
show Request
req)
                   StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
                   StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"and the content of the error was:"
                   StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
                   StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
string (HttpExceptionContent -> String
forall a. Show a => a -> String
show HttpExceptionContent
content)
            isNotFound404 :: Bool
isNotFound404 = case HttpExceptionContent
content of
                              StatusCodeException Response ()
res ByteString
_ ->
                                Response () -> Status
forall body. Response body -> Status
responseStatus Response ()
res Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
notFound404
                              HttpExceptionContent
_ -> Bool
False
        in  (StyleDoc
msg', Bool
isNotFound404)
      DownloadHttpError (InvalidUrlException String
url' String
reason) ->
        let msg' :: StyleDoc
msg' = [StyleDoc] -> StyleDoc
fillSep
                     [ String -> StyleDoc
flow String
"an HTTP error. The URL"
                     , Style -> StyleDoc -> StyleDoc
style Style
Url (String -> StyleDoc
forall a. IsString a => String -> a
fromString String
url')
                     , String -> StyleDoc
flow String
"was considered invalid because"
                     , String -> StyleDoc
forall a. IsString a => String -> a
fromString String
reason StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
                     ]
        in  (StyleDoc
msg', Bool
False)
      VerifiedDownloadException
_ -> let msg' :: StyleDoc
msg' =    String -> StyleDoc
flow String
"the following error:"
                      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
                      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
forall a. IsString a => String -> a
fromString (VerifiedDownloadException -> String
forall e. Exception e => e -> String
displayException VerifiedDownloadException
err)
           in  (StyleDoc
msg', Bool
False)
  pretty (LoadTemplateFailed TemplateName
name Path b File
path) =
    StyleDoc
"[S-3650]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ String -> StyleDoc
flow String
"Stack failed to load the downloaded template"
         , Style -> StyleDoc -> StyleDoc
style Style
Current (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ TemplateName -> Text
templateName TemplateName
name)
         , StyleDoc
"from"
         , Path b File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path b File
path StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         ]
  pretty (ExtractTemplateFailed TemplateName
name Path b File
path String
err) =
    StyleDoc
"[S-9582]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ String -> StyleDoc
flow String
"Stack failed to extract the loaded template"
         , Style -> StyleDoc -> StyleDoc
style Style
Current (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ TemplateName -> Text
templateName TemplateName
name)
         , StyleDoc
"at"
         , Path b File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path b File
path StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         ]
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"While extracting, Stack encountered the following error:"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
string String
err
  pretty (TemplateInvalid TemplateName
name StyleDoc
why) =
    StyleDoc
"[S-9490]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ String -> StyleDoc
flow String
"Stack failed to use the template"
         , Style -> StyleDoc -> StyleDoc
style Style
Current (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ TemplateName -> Text
templateName TemplateName
name) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
         , StyleDoc
"as"
         , StyleDoc
why
         ]
  pretty (MagicPackageNameInvalid String
name) =
    StyleDoc
"[S-5682]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ String -> StyleDoc
flow String
"Stack declined to create a new directory for project"
         , Style -> StyleDoc -> StyleDoc
style Style
Current (String -> StyleDoc
forall a. IsString a => String -> a
fromString String
name) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
         , String -> StyleDoc
flow String
"as package"
         , String -> StyleDoc
forall a. IsString a => String -> a
fromString String
name
         , String -> StyleDoc
flow String
"is 'wired-in' to a version of GHC. That can cause build \
                \errors."
         ]
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         ( String -> StyleDoc
flow String
"The names blocked by Stack are:"
         StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: Maybe Style -> Bool -> [StyleDoc] -> [StyleDoc]
forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList Maybe Style
forall a. Maybe a
Nothing Bool
False
             ((PackageName -> StyleDoc) -> [PackageName] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map PackageName -> StyleDoc
toStyleDoc ([PackageName] -> [PackageName]
forall a. Ord a => [a] -> [a]
L.sort ([PackageName] -> [PackageName]) -> [PackageName] -> [PackageName]
forall a b. (a -> b) -> a -> b
$ Set PackageName -> [PackageName]
forall a. Set a -> [a]
S.toList Set PackageName
wiredInPackages))
         )
   where
    toStyleDoc :: PackageName -> StyleDoc
    toStyleDoc :: PackageName -> StyleDoc
toStyleDoc = String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> (PackageName -> String) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString
  pretty (AttemptedOverwrites Text
name [Path Abs File]
fps) =
    StyleDoc
"[S-3113]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ String -> StyleDoc
flow String
"Stack declined to apply the template"
         , Style -> StyleDoc -> StyleDoc
style Style
Current (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> (Text -> String) -> Text -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> StyleDoc) -> Text -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text
name) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
         , String -> StyleDoc
flow String
"as it would create files that already exist."
         ]
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"The template would create the following existing files:"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList ((Path Abs File -> StyleDoc) -> [Path Abs File] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Style -> StyleDoc -> StyleDoc
style Style
File (StyleDoc -> StyleDoc)
-> (Path Abs File -> StyleDoc) -> Path Abs File -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty) [Path Abs File]
fps)
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ StyleDoc
"Use the"
         , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--force"
         , StyleDoc
"flag to ignore this and overwrite those files."
         ]

instance Exception NewPrettyException

--------------------------------------------------------------------------------

-- Main project creation


-- | Type representing command line options for the @stack new@ command (other

-- than those applicable also to the @stack init@ command).

data NewOpts = NewOpts
  { NewOpts -> PackageName
newOptsProjectName  :: PackageName
    -- ^ Name of the project to create.

  , NewOpts -> Bool
newOptsCreateBare   :: Bool
    -- ^ Whether to create the project without a directory.

  , NewOpts -> Bool
newOptsInit         :: Bool
    -- ^ Whether to initialise the project for use with Stack.

  , NewOpts -> Maybe TemplateName
newOptsTemplate     :: Maybe TemplateName
    -- ^ Name of the template to use.

  , NewOpts -> Map Text Text
newOptsNonceParams  :: Map Text Text
    -- ^ Nonce parameters specified just for this invocation.

  }

-- | Function underlying the @stack new@ command. Create a project directory

-- structure and initialize the Stack config.

newCmd :: (NewOpts, InitOpts) -> RIO Runner ()
newCmd :: (NewOpts, InitOpts) -> RIO Runner ()
newCmd (NewOpts
newOpts, InitOpts
initOpts) =
  RIO Runner () -> RIO Runner ()
forall a. RIO Runner a -> RIO Runner a
withGlobalProject (RIO Runner () -> RIO Runner ()) -> RIO Runner () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$ ShouldReexec -> RIO Config () -> RIO Runner ()
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
YesReexec (RIO Config () -> RIO Runner ()) -> RIO Config () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$ do
    Path Abs Dir
dir <- NewOpts -> Bool -> RIO Config (Path Abs Dir)
forall env.
HasConfig env =>
NewOpts -> Bool -> RIO env (Path Abs Dir)
new NewOpts
newOpts (InitOpts -> Bool
forceOverwrite InitOpts
initOpts)
    Bool
exists <- Path Abs File -> RIO Config Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist (Path Abs File -> RIO Config Bool)
-> Path Abs File -> RIO Config Bool
forall a b. (a -> b) -> a -> b
$ Path Abs Dir
dir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
stackDotYaml
    Bool -> RIO Config () -> RIO Config ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NewOpts -> Bool
newOptsInit NewOpts
newOpts Bool -> Bool -> Bool
&& (InitOpts -> Bool
forceOverwrite InitOpts
initOpts Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
exists)) (RIO Config () -> RIO Config ()) -> RIO Config () -> RIO Config ()
forall a b. (a -> b) -> a -> b
$ do
      GlobalOpts
go <- Getting GlobalOpts Config GlobalOpts -> RIO Config GlobalOpts
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting GlobalOpts Config GlobalOpts
forall env. HasRunner env => Lens' env GlobalOpts
Lens' Config GlobalOpts
globalOptsL
      Path Abs Dir -> InitOpts -> Maybe AbstractResolver -> RIO Config ()
forall env.
(HasConfig env, HasGHCVariant env) =>
Path Abs Dir -> InitOpts -> Maybe AbstractResolver -> RIO env ()
initProject Path Abs Dir
dir InitOpts
initOpts (GlobalOpts -> Maybe AbstractResolver
globalResolver GlobalOpts
go)

-- | Create a new project with the given options.

new :: HasConfig env => NewOpts -> Bool -> RIO env (Path Abs Dir)
new :: forall env.
HasConfig env =>
NewOpts -> Bool -> RIO env (Path Abs Dir)
new NewOpts
opts Bool
forceOverwrite = do
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PackageName
project PackageName -> Set PackageName -> Bool
forall a. Eq a => a -> Set a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Set PackageName
wiredInPackages) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
      NewPrettyException -> RIO env ()
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (NewPrettyException -> RIO env ())
-> NewPrettyException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ String -> NewPrettyException
MagicPackageNameInvalid String
projectName
  Path Abs Dir
pwd <- RIO env (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
  Path Abs Dir
absDir <- if Bool
bare
              then Path Abs Dir -> RIO env (Path Abs Dir)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs Dir
pwd
              else do Path Rel Dir
relDir <- String -> RIO env (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir (PackageName -> String
packageNameString PackageName
project)
                      Path Abs Dir -> RIO env (Path Abs Dir)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir
pwd Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDir)
  Bool
exists <- Path Abs Dir -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist Path Abs Dir
absDir
  Maybe TemplateName
configTemplate <- Getting (Maybe TemplateName) env (Maybe TemplateName)
-> RIO env (Maybe TemplateName)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Maybe TemplateName) env (Maybe TemplateName)
 -> RIO env (Maybe TemplateName))
-> Getting (Maybe TemplateName) env (Maybe TemplateName)
-> RIO env (Maybe TemplateName)
forall a b. (a -> b) -> a -> b
$ (Config -> Const (Maybe TemplateName) Config)
-> env -> Const (Maybe TemplateName) env
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL((Config -> Const (Maybe TemplateName) Config)
 -> env -> Const (Maybe TemplateName) env)
-> ((Maybe TemplateName
     -> Const (Maybe TemplateName) (Maybe TemplateName))
    -> Config -> Const (Maybe TemplateName) Config)
-> Getting (Maybe TemplateName) env (Maybe TemplateName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Config -> Maybe TemplateName)
-> SimpleGetter Config (Maybe TemplateName)
forall s a. (s -> a) -> SimpleGetter s a
to Config -> Maybe TemplateName
configDefaultTemplate
  let template :: TemplateName
template = TemplateName -> Maybe TemplateName -> TemplateName
forall a. a -> Maybe a -> a
fromMaybe TemplateName
defaultTemplateName (Maybe TemplateName -> TemplateName)
-> Maybe TemplateName -> TemplateName
forall a b. (a -> b) -> a -> b
$ [Maybe TemplateName] -> Maybe TemplateName
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [ Maybe TemplateName
cliOptionTemplate
                                                      , Maybe TemplateName
configTemplate
                                                      ]
  if Bool
exists Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
bare
    then NewPrettyException -> RIO env (Path Abs Dir)
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (NewPrettyException -> RIO env (Path Abs Dir))
-> NewPrettyException -> RIO env (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ String -> Path Abs Dir -> NewPrettyException
ProjectDirAlreadyExists String
projectName Path Abs Dir
absDir
    else do
      Text
templateText <- TemplateName -> (TemplateFrom -> RIO env ()) -> RIO env Text
forall env.
HasConfig env =>
TemplateName -> (TemplateFrom -> RIO env ()) -> RIO env Text
loadTemplate TemplateName
template (Path Abs Dir -> TemplateName -> TemplateFrom -> RIO env ()
forall {env} {m :: * -> *} {b}.
(HasTerm env, MonadReader env m, MonadIO m) =>
Path b Dir -> TemplateName -> TemplateFrom -> m ()
logUsing Path Abs Dir
absDir TemplateName
template)
      Map (Path Abs File) ByteString
files <-
        PackageName
-> TemplateName
-> Map Text Text
-> Path Abs Dir
-> Text
-> RIO env (Map (Path Abs File) ByteString)
forall env.
HasConfig env =>
PackageName
-> TemplateName
-> Map Text Text
-> Path Abs Dir
-> Text
-> RIO env (Map (Path Abs File) ByteString)
applyTemplate
          PackageName
project
          TemplateName
template
          (NewOpts -> Map Text Text
newOptsNonceParams NewOpts
opts)
          Path Abs Dir
absDir
          Text
templateText
      Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
forceOverwrite Bool -> Bool -> Bool
&& Bool
bare) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
        Text -> [Path Abs File] -> RIO env ()
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Text -> [Path Abs File] -> m ()
checkForOverwrite (TemplateName -> Text
templateName TemplateName
template) (Map (Path Abs File) ByteString -> [Path Abs File]
forall k a. Map k a -> [k]
M.keys Map (Path Abs File) ByteString
files)
      Map (Path Abs File) ByteString -> RIO env ()
forall (m :: * -> *).
MonadIO m =>
Map (Path Abs File) ByteString -> m ()
writeTemplateFiles Map (Path Abs File) ByteString
files
      Path Abs Dir -> RIO env ()
forall env. HasConfig env => Path Abs Dir -> RIO env ()
runTemplateInits Path Abs Dir
absDir
      Path Abs Dir -> RIO env (Path Abs Dir)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs Dir
absDir
 where
  cliOptionTemplate :: Maybe TemplateName
cliOptionTemplate = NewOpts -> Maybe TemplateName
newOptsTemplate NewOpts
opts
  project :: PackageName
project = NewOpts -> PackageName
newOptsProjectName NewOpts
opts
  projectName :: String
projectName = PackageName -> String
packageNameString PackageName
project
  bare :: Bool
bare = NewOpts -> Bool
newOptsCreateBare NewOpts
opts
  logUsing :: Path b Dir -> TemplateName -> TemplateFrom -> m ()
logUsing Path b Dir
absDir TemplateName
template TemplateFrom
templateFrom =
    let loading :: StyleDoc
loading = case TemplateFrom
templateFrom of
                    TemplateFrom
LocalTemp -> String -> StyleDoc
flow String
"Loading local"
                    TemplateFrom
RemoteTemp -> StyleDoc
"Downloading"
    in  StyleDoc -> m ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo
          ( [StyleDoc] -> StyleDoc
fillSep
              [ StyleDoc
loading
              , StyleDoc
"template"
              , Style -> StyleDoc -> StyleDoc
style
                  Style
Current
                  (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ TemplateName -> Text
templateName TemplateName
template)
              , String -> StyleDoc
flow String
"to create project"
              , Style -> StyleDoc -> StyleDoc
style Style
Current (String -> StyleDoc
forall a. IsString a => String -> a
fromString String
projectName)
              , StyleDoc
"in"
              ,    ( if Bool
bare
                       then String -> StyleDoc
flow String
"the current directory"
                       else [StyleDoc] -> StyleDoc
fillSep
                              [ StyleDoc
"directory"
                              , Path Rel Dir -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty (Path Rel Dir -> StyleDoc) -> Path Rel Dir -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Path b Dir -> Path Rel Dir
forall b. Path b Dir -> Path Rel Dir
dirname Path b Dir
absDir
                              ]
                   )
                StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"..."
              ]
            )

data TemplateFrom = LocalTemp | RemoteTemp

-- | Download and read in a template's text content.

loadTemplate ::
     forall env. HasConfig env
  => TemplateName
  -> (TemplateFrom -> RIO env ())
  -> RIO env Text
loadTemplate :: forall env.
HasConfig env =>
TemplateName -> (TemplateFrom -> RIO env ()) -> RIO env Text
loadTemplate TemplateName
name TemplateFrom -> RIO env ()
logIt = do
  Path Abs Dir
templateDir <- Getting (Path Abs Dir) env (Path Abs Dir) -> RIO env (Path Abs Dir)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Path Abs Dir) env (Path Abs Dir)
 -> RIO env (Path Abs Dir))
-> Getting (Path Abs Dir) env (Path Abs Dir)
-> RIO env (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ (Config -> Const (Path Abs Dir) Config)
-> env -> Const (Path Abs Dir) env
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL((Config -> Const (Path Abs Dir) Config)
 -> env -> Const (Path Abs Dir) env)
-> ((Path Abs Dir -> Const (Path Abs Dir) (Path Abs Dir))
    -> Config -> Const (Path Abs Dir) Config)
-> Getting (Path Abs Dir) env (Path Abs Dir)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Config -> Path Abs Dir) -> SimpleGetter Config (Path Abs Dir)
forall s a. (s -> a) -> SimpleGetter s a
to Config -> Path Abs Dir
templatesDir
  case TemplateName -> TemplatePath
templatePath TemplateName
name of
    AbsPath Path Abs File
absFile ->
      TemplateFrom -> RIO env ()
logIt TemplateFrom
LocalTemp RIO env () -> RIO env Text -> RIO env Text
forall a b. RIO env a -> RIO env b -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Path Abs File -> (ByteString -> Either String Text) -> RIO env Text
forall b.
Path b File -> (ByteString -> Either String Text) -> RIO env Text
loadLocalFile Path Abs File
absFile ByteString -> Either String Text
eitherByteStringToText
    UrlPath String
s -> do
      let settings :: TemplateDownloadSettings
settings = String -> TemplateDownloadSettings
asIsFromUrl String
s
      TemplateDownloadSettings -> Path Abs Dir -> RIO env Text
downloadFromUrl TemplateDownloadSettings
settings Path Abs Dir
templateDir
    RelPath String
rawParam Path Rel File
relFile ->
      RIO env Text -> (PrettyException -> RIO env Text) -> RIO env Text
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch
        (do Text
f <- Path Rel File -> (ByteString -> Either String Text) -> RIO env Text
forall b.
Path b File -> (ByteString -> Either String Text) -> RIO env Text
loadLocalFile Path Rel File
relFile ByteString -> Either String Text
eitherByteStringToText
            TemplateFrom -> RIO env ()
logIt TemplateFrom
LocalTemp
            Text -> RIO env Text
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
f)
        ( \(PrettyException
e :: PrettyException) -> do
            TemplateDownloadSettings
settings <- RIO env TemplateDownloadSettings
-> Maybe (RIO env TemplateDownloadSettings)
-> RIO env TemplateDownloadSettings
forall a. a -> Maybe a -> a
fromMaybe (PrettyException -> RIO env TemplateDownloadSettings
forall e a. Exception e => e -> RIO env a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM PrettyException
e) (String -> Maybe (RIO env TemplateDownloadSettings)
relSettings String
rawParam)
            let url :: String
url = TemplateDownloadSettings -> String
tplDownloadUrl TemplateDownloadSettings
settings
                mBasicAuth :: Maybe (ByteString, ByteString)
mBasicAuth = TemplateDownloadSettings -> Maybe (ByteString, ByteString)
tplBasicAuth TemplateDownloadSettings
settings
                extract :: ByteString -> Either String Text
extract = TemplateDownloadSettings -> ByteString -> Either String Text
tplExtract TemplateDownloadSettings
settings
            String
-> Maybe (ByteString, ByteString)
-> (ByteString -> Either String Text)
-> Path Abs File
-> RIO env Text
downloadTemplate String
url Maybe (ByteString, ByteString)
mBasicAuth ByteString -> Either String Text
extract (Path Abs Dir
templateDir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFile)
        )
    RepoPath RepoTemplatePath
rtp -> do
      TemplateDownloadSettings
settings <- RepoTemplatePath -> RIO env TemplateDownloadSettings
forall env.
HasTerm env =>
RepoTemplatePath -> RIO env TemplateDownloadSettings
settingsFromRepoTemplatePath RepoTemplatePath
rtp
      TemplateDownloadSettings -> Path Abs Dir -> RIO env Text
downloadFromUrl TemplateDownloadSettings
settings Path Abs Dir
templateDir

 where
  loadLocalFile :: Path b File
                -> (ByteString -> Either String Text)
                -> RIO env Text
  loadLocalFile :: forall b.
Path b File -> (ByteString -> Either String Text) -> RIO env Text
loadLocalFile Path b File
path ByteString -> Either String Text
extract = 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
"Opening local template: \""
      Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path b File -> String
forall b t. Path b t -> String
toFilePath Path b File
path)
      Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\""
    Bool
exists <- Path b File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path b File
path
    if Bool
exists
      then do
        ByteString
bs <- String -> RIO env ByteString
forall (m :: * -> *). MonadIO m => String -> m ByteString
readFileBinary (Path b File -> String
forall b t. Path b t -> String
toFilePath Path b File
path) --readFileUtf8 (toFilePath path)

        case ByteString -> Either String Text
extract ByteString
bs of
          Left String
err -> NewPrettyException -> RIO env Text
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (NewPrettyException -> RIO env Text)
-> NewPrettyException -> RIO env Text
forall a b. (a -> b) -> a -> b
$ TemplateName -> Path b File -> String -> NewPrettyException
forall b.
TemplateName -> Path b File -> String -> NewPrettyException
ExtractTemplateFailed TemplateName
name Path b File
path String
err
          Right Text
template ->
              Text -> RIO env Text
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
template
      else NewPrettyException -> RIO env Text
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (NewPrettyException -> RIO env Text)
-> NewPrettyException -> RIO env Text
forall a b. (a -> b) -> a -> b
$ TemplateName -> Path b File -> NewPrettyException
forall b. TemplateName -> Path b File -> NewPrettyException
LoadTemplateFailed TemplateName
name Path b File
path

  relSettings :: String -> Maybe (RIO env TemplateDownloadSettings)
  relSettings :: String -> Maybe (RIO env TemplateDownloadSettings)
relSettings String
req = do
    RepoTemplatePath
rtp <- RepoService -> Text -> Maybe RepoTemplatePath
parseRepoPathWithService RepoService
defaultRepoService (String -> Text
T.pack String
req)
    RIO env TemplateDownloadSettings
-> Maybe (RIO env TemplateDownloadSettings)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RepoTemplatePath -> RIO env TemplateDownloadSettings
forall env.
HasTerm env =>
RepoTemplatePath -> RIO env TemplateDownloadSettings
settingsFromRepoTemplatePath RepoTemplatePath
rtp)

  downloadFromUrl :: TemplateDownloadSettings -> Path Abs Dir -> RIO env Text
  downloadFromUrl :: TemplateDownloadSettings -> Path Abs Dir -> RIO env Text
downloadFromUrl TemplateDownloadSettings
settings Path Abs Dir
templateDir = do
    let url :: String
url = TemplateDownloadSettings -> String
tplDownloadUrl TemplateDownloadSettings
settings
        mBasicAuth :: Maybe (ByteString, ByteString)
mBasicAuth = TemplateDownloadSettings -> Maybe (ByteString, ByteString)
tplBasicAuth TemplateDownloadSettings
settings
        rel :: Path Rel File
rel = Path Rel File -> Maybe (Path Rel File) -> Path Rel File
forall a. a -> Maybe a -> a
fromMaybe Path Rel File
backupUrlRelPath (String -> Maybe (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile String
url)
    String
-> Maybe (ByteString, ByteString)
-> (ByteString -> Either String Text)
-> Path Abs File
-> RIO env Text
downloadTemplate String
url Maybe (ByteString, ByteString)
mBasicAuth (TemplateDownloadSettings -> ByteString -> Either String Text
tplExtract TemplateDownloadSettings
settings) (Path Abs Dir
templateDir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
rel)

  downloadTemplate ::
       String
    -> Maybe (ByteString, ByteString)
       -- ^ Optional HTTP \'Basic\' authentication (type, credentials)

    -> (ByteString -> Either String Text)
    -> Path Abs File
    -> RIO env Text
  downloadTemplate :: String
-> Maybe (ByteString, ByteString)
-> (ByteString -> Either String Text)
-> Path Abs File
-> RIO env Text
downloadTemplate String
url Maybe (ByteString, ByteString)
mBasicAuth ByteString -> Either String Text
extract Path Abs File
path = do
    Request
req <- String -> RIO env Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
url
    let authReq :: Request
authReq = (Request -> Request)
-> ((ByteString, ByteString) -> Request -> Request)
-> Maybe (ByteString, ByteString)
-> Request
-> Request
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Request -> Request
forall a. a -> a
id ((ByteString -> ByteString -> Request -> Request)
-> (ByteString, ByteString) -> Request -> Request
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ByteString -> ByteString -> Request -> Request
applyBasicAuth) Maybe (ByteString, ByteString)
mBasicAuth Request
req
        dReq :: DownloadRequest
dReq = Bool -> DownloadRequest -> DownloadRequest
setForceDownload Bool
True (DownloadRequest -> DownloadRequest)
-> DownloadRequest -> DownloadRequest
forall a b. (a -> b) -> a -> b
$
                   Request -> DownloadRequest
mkDownloadRequest (Request -> Request
setRequestCheckStatus Request
authReq)
    TemplateFrom -> RIO env ()
logIt TemplateFrom
RemoteTemp
    RIO env ()
-> (VerifiedDownloadException -> RIO env ()) -> RIO env ()
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch
      ( do let label :: Text
label = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
path
           Bool
res <- DownloadRequest
-> Path Abs File -> Text -> Maybe Int -> RIO env Bool
forall env.
HasTerm env =>
DownloadRequest
-> Path Abs File -> Text -> Maybe Int -> RIO env Bool
verifiedDownloadWithProgress DownloadRequest
dReq Path Abs File
path Text
label Maybe Int
forall a. Maybe a
Nothing
           if Bool
res
             then Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) =>
Utf8Builder -> m ()
logStickyDone (Utf8Builder
"Downloaded " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
label Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
".")
             else Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) =>
Utf8Builder -> m ()
logStickyDone Utf8Builder
"Already downloaded."
      )
      (String -> Path Abs File -> VerifiedDownloadException -> RIO env ()
useCachedVersionOrThrow String
url Path Abs File
path)
    Path Abs File -> (ByteString -> Either String Text) -> RIO env Text
forall b.
Path b File -> (ByteString -> Either String Text) -> RIO env Text
loadLocalFile Path Abs File
path ByteString -> Either String Text
extract

  useCachedVersionOrThrow :: String
                          -> Path Abs File
                          -> VerifiedDownloadException
                          -> RIO env ()
  useCachedVersionOrThrow :: String -> Path Abs File -> VerifiedDownloadException -> RIO env ()
useCachedVersionOrThrow String
url Path Abs File
path VerifiedDownloadException
exception = do
    Bool
exists <- Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
path

    if Bool
exists
      then
        StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn
          ( String -> StyleDoc
flow String
"Tried to download the template but an error was \
                 \found. Using cached local version. It may not be the \
                 \most recent version though."
          )
      else
        NewPrettyException -> RIO env ()
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (NewPrettyException -> RIO env ())
-> NewPrettyException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Text -> String -> VerifiedDownloadException -> NewPrettyException
DownloadTemplateFailed (TemplateName -> Text
templateName TemplateName
name) String
url VerifiedDownloadException
exception

-- | Type representing settings for the download of Stack project templates.

data TemplateDownloadSettings = TemplateDownloadSettings
  { TemplateDownloadSettings -> String
tplDownloadUrl :: String
  , TemplateDownloadSettings -> Maybe (ByteString, ByteString)
tplBasicAuth :: Maybe (ByteString, ByteString)
    -- ^ Optional HTTP 'Basic' authentication (type, credentials)

  , TemplateDownloadSettings -> ByteString -> Either String Text
tplExtract :: ByteString -> Either String Text
  }

eitherByteStringToText :: ByteString -> Either String Text
eitherByteStringToText :: ByteString -> Either String Text
eitherByteStringToText = (UnicodeException -> String)
-> Either UnicodeException Text -> Either String Text
forall a1 a2 b. (a1 -> a2) -> Either a1 b -> Either a2 b
mapLeft UnicodeException -> String
forall a. Show a => a -> String
show (Either UnicodeException Text -> Either String Text)
-> (ByteString -> Either UnicodeException Text)
-> ByteString
-> Either String Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Text
decodeUtf8'

asIsFromUrl :: String -> TemplateDownloadSettings
asIsFromUrl :: String -> TemplateDownloadSettings
asIsFromUrl String
url = TemplateDownloadSettings
  { tplDownloadUrl :: String
tplDownloadUrl = String
url
  , tplBasicAuth :: Maybe (ByteString, ByteString)
tplBasicAuth = Maybe (ByteString, ByteString)
forall a. Maybe a
Nothing
  , tplExtract :: ByteString -> Either String Text
tplExtract = ByteString -> Either String Text
eitherByteStringToText
  }

-- | Construct settings for downloading a Stack project template from a

-- repository.

settingsFromRepoTemplatePath ::
    HasTerm env
 => RepoTemplatePath
 -> RIO env TemplateDownloadSettings
settingsFromRepoTemplatePath :: forall env.
HasTerm env =>
RepoTemplatePath -> RIO env TemplateDownloadSettings
settingsFromRepoTemplatePath (RepoTemplatePath RepoService
GitHub Text
user Text
name) = do
  let basicAuthMsg :: String -> m ()
basicAuthMsg String
token = [StyleDoc] -> m ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
        [ String -> StyleDoc
flow String
"Using content of"
        , String -> StyleDoc
forall a. IsString a => String -> a
fromString String
token
        , String -> StyleDoc
flow String
" environment variable to authenticate GitHub REST API."
        ]
  Maybe (ByteString, ByteString)
mBasicAuth <- do
    String
wantGitHubToken <- IO String -> RIO env String
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> RIO env String) -> IO String -> RIO env String
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
gitHubTokenEnvVar
    if Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null String
wantGitHubToken)
      then do
         String -> RIO env ()
forall {env} {m :: * -> *}.
(HasTerm env, MonadReader env m, MonadIO m) =>
String -> m ()
basicAuthMsg String
gitHubTokenEnvVar
         Maybe (ByteString, ByteString)
-> RIO env (Maybe (ByteString, ByteString))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (ByteString, ByteString)
 -> RIO env (Maybe (ByteString, ByteString)))
-> Maybe (ByteString, ByteString)
-> RIO env (Maybe (ByteString, ByteString))
forall a b. (a -> b) -> a -> b
$ (ByteString, ByteString) -> Maybe (ByteString, ByteString)
forall a. a -> Maybe a
Just (ByteString
gitHubBasicAuthType, String -> ByteString
forall a. IsString a => String -> a
fromString String
wantGitHubToken)
      else do
        String
wantAltGitHubToken <-
          IO String -> RIO env String
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> RIO env String) -> IO String -> RIO env String
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
altGitHubTokenEnvVar
        if Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null String
wantAltGitHubToken)
        then do
          String -> RIO env ()
forall {env} {m :: * -> *}.
(HasTerm env, MonadReader env m, MonadIO m) =>
String -> m ()
basicAuthMsg String
altGitHubTokenEnvVar
          Maybe (ByteString, ByteString)
-> RIO env (Maybe (ByteString, ByteString))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (ByteString, ByteString)
 -> RIO env (Maybe (ByteString, ByteString)))
-> Maybe (ByteString, ByteString)
-> RIO env (Maybe (ByteString, ByteString))
forall a b. (a -> b) -> a -> b
$ (ByteString, ByteString) -> Maybe (ByteString, ByteString)
forall a. a -> Maybe a
Just (ByteString
gitHubBasicAuthType, String -> ByteString
forall a. IsString a => String -> a
fromString String
wantAltGitHubToken)
        else Maybe (ByteString, ByteString)
-> RIO env (Maybe (ByteString, ByteString))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ByteString, ByteString)
forall a. Maybe a
Nothing
  TemplateDownloadSettings -> RIO env TemplateDownloadSettings
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TemplateDownloadSettings -> RIO env TemplateDownloadSettings)
-> TemplateDownloadSettings -> RIO env TemplateDownloadSettings
forall a b. (a -> b) -> a -> b
$ TemplateDownloadSettings
    { tplDownloadUrl :: String
tplDownloadUrl = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"https://api.github.com/repos/"
        , Text -> String
T.unpack Text
user
        , String
"/stack-templates/contents/"
        , Text -> String
T.unpack Text
name
        ]
    , tplBasicAuth :: Maybe (ByteString, ByteString)
tplBasicAuth = Maybe (ByteString, ByteString)
mBasicAuth
    , tplExtract :: ByteString -> Either String Text
tplExtract = \ByteString
bs -> do
        Value
decodedJson <- ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
eitherDecode (ByteString -> ByteString
LB.fromStrict ByteString
bs)
        case Value
decodedJson of
          Object Object
o | Just (String Text
content) <- Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
"content" Object
o -> do
            let noNewlines :: Text -> Text
noNewlines = (Char -> Bool) -> Text -> Text
T.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n')
            ByteString
bsContent <- ByteString -> Either String ByteString
B64.decode (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8 (Text -> Text
noNewlines Text
content)
            (UnicodeException -> String)
-> Either UnicodeException Text -> Either String Text
forall a1 a2 b. (a1 -> a2) -> Either a1 b -> Either a2 b
mapLeft UnicodeException -> String
forall a. Show a => a -> String
show (Either UnicodeException Text -> Either String Text)
-> Either UnicodeException Text -> Either String Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
bsContent
          Value
_ ->
            String -> Either String Text
forall a b. a -> Either a b
Left String
"Couldn't parse GitHub response as a JSON object with a \
                 \\"content\" field"
    }
settingsFromRepoTemplatePath (RepoTemplatePath RepoService
GitLab Text
user Text
name) = TemplateDownloadSettings -> RIO env TemplateDownloadSettings
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TemplateDownloadSettings -> RIO env TemplateDownloadSettings)
-> TemplateDownloadSettings -> RIO env TemplateDownloadSettings
forall a b. (a -> b) -> a -> b
$
  String -> TemplateDownloadSettings
asIsFromUrl (String -> TemplateDownloadSettings)
-> String -> TemplateDownloadSettings
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"https://gitlab.com"
    , String
"/"
    , Text -> String
T.unpack Text
user
    , String
"/stack-templates/raw/master/"
    , Text -> String
T.unpack Text
name
    ]
settingsFromRepoTemplatePath (RepoTemplatePath RepoService
Bitbucket Text
user Text
name) = TemplateDownloadSettings -> RIO env TemplateDownloadSettings
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TemplateDownloadSettings -> RIO env TemplateDownloadSettings)
-> TemplateDownloadSettings -> RIO env TemplateDownloadSettings
forall a b. (a -> b) -> a -> b
$
  String -> TemplateDownloadSettings
asIsFromUrl (String -> TemplateDownloadSettings)
-> String -> TemplateDownloadSettings
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"https://bitbucket.org"
    , String
"/"
    , Text -> String
T.unpack Text
user
    , String
"/stack-templates/raw/master/"
    , Text -> String
T.unpack Text
name
    ]

-- | Apply and unpack a template into a directory.

applyTemplate ::
     HasConfig env
  => PackageName
  -> TemplateName
  -> Map Text Text
  -> Path Abs Dir
  -> Text
  -> RIO env (Map (Path Abs File) LB.ByteString)
applyTemplate :: forall env.
HasConfig env =>
PackageName
-> TemplateName
-> Map Text Text
-> Path Abs Dir
-> Text
-> RIO env (Map (Path Abs File) ByteString)
applyTemplate PackageName
project TemplateName
template Map Text Text
nonceParams Path Abs Dir
dir Text
templateText = do
  Config
config <- Getting Config env Config -> RIO env Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL
  Text
currentYear <- do
    UTCTime
now <- IO UTCTime -> RIO env UTCTime
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    let (Year
year, Int
_, Int
_) = Day -> (Year, Int, Int)
toGregorian (UTCTime -> Day
utctDay UTCTime
now)
    Text -> RIO env Text
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> RIO env Text) -> Text -> RIO env Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> (Year -> String) -> Year -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Year -> String
forall a. Show a => a -> String
show (Year -> Text) -> Year -> Text
forall a b. (a -> b) -> a -> b
$ Year
year
  let context :: Map Text Text
context = [Map Text Text] -> Map Text Text
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
M.unions [Map Text Text
nonceParams, Map Text Text
nameParams, Map Text Text
configParams, Map Text Text
yearParam]
       where
        nameAsVarId :: Text
nameAsVarId = HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"-" Text
"_" (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
project
        nameAsModule :: Text
nameAsModule = (Char -> Bool) -> Text -> Text
T.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ') (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.toTitle (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"-" Text
" " (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$
                           String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
project
        nameParams :: Map Text Text
nameParams = [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ (Text
"name", String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
project)
                                , (Text
"name-as-varid", Text
nameAsVarId)
                                , (Text
"name-as-module", Text
nameAsModule) ]
        configParams :: Map Text Text
configParams = Config -> Map Text Text
configTemplateParams Config
config
        yearParam :: Map Text Text
yearParam = Text -> Text -> Map Text Text
forall k a. k -> a -> Map k a
M.singleton Text
"year" Text
currentYear
  Map String ByteString
files :: Map FilePath LB.ByteString <-
    RIO env (Map String ByteString)
-> (ProjectTemplateException -> RIO env (Map String ByteString))
-> RIO env (Map String ByteString)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch
      ( WriterT (Map String ByteString) (RIO env) ()
-> RIO env (Map String ByteString)
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT (WriterT (Map String ByteString) (RIO env) ()
 -> RIO env (Map String ByteString))
-> WriterT (Map String ByteString) (RIO env) ()
-> RIO env (Map String ByteString)
forall a b. (a -> b) -> a -> b
$ ConduitT () Void (WriterT (Map String ByteString) (RIO env)) ()
-> WriterT (Map String ByteString) (RIO env) ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void (WriterT (Map String ByteString) (RIO env)) ()
 -> WriterT (Map String ByteString) (RIO env) ())
-> ConduitT () Void (WriterT (Map String ByteString) (RIO env)) ()
-> WriterT (Map String ByteString) (RIO env) ()
forall a b. (a -> b) -> a -> b
$
            ByteString
-> ConduitT
     () ByteString (WriterT (Map String ByteString) (RIO env)) ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Text -> ByteString
T.encodeUtf8 Text
templateText) ConduitT
  () ByteString (WriterT (Map String ByteString) (RIO env)) ()
-> ConduitT
     ByteString Void (WriterT (Map String ByteString) (RIO env)) ()
-> ConduitT () Void (WriterT (Map String ByteString) (RIO env)) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.|
            (String
 -> ConduitT
      ByteString Void (WriterT (Map String ByteString) (RIO env)) ())
-> (Text -> Text)
-> ConduitT
     ByteString Void (WriterT (Map String ByteString) (RIO env)) ()
forall (m :: * -> *) o.
MonadThrow m =>
(String -> ConduitM ByteString o m ())
-> (Text -> Text) -> ConduitM ByteString o m ()
unpackTemplate String
-> ConduitT
     ByteString Void (WriterT (Map String ByteString) (RIO env)) ()
forall (m :: * -> *).
MonadWriter (Map String ByteString) m =>
FileReceiver m
receiveMem Text -> Text
forall a. a -> a
id
      )
      ( \(ProjectTemplateException
e :: ProjectTemplateException) ->
          NewPrettyException -> RIO env (Map String ByteString)
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (NewPrettyException -> RIO env (Map String ByteString))
-> NewPrettyException -> RIO env (Map String ByteString)
forall a b. (a -> b) -> a -> b
$ TemplateName -> StyleDoc -> NewPrettyException
TemplateInvalid TemplateName
template (String -> StyleDoc
string (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ ProjectTemplateException -> String
forall e. Exception e => e -> String
displayException ProjectTemplateException
e)
      )
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Map String ByteString -> Bool
forall k a. Map k a -> Bool
M.null Map String ByteString
files) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
    NewPrettyException -> RIO env ()
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (NewPrettyException -> RIO env ())
-> NewPrettyException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ TemplateName -> StyleDoc -> NewPrettyException
TemplateInvalid
      TemplateName
template
      (String -> StyleDoc
flow String
"the template does not contain any files.")

  let isPkgSpec :: String -> Bool
isPkgSpec String
f = String
".cabal" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isSuffixOf` String
f Bool -> Bool -> Bool
|| String
f String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"package.yaml"
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any String -> Bool
isPkgSpec ([String] -> Bool)
-> (Map String ByteString -> [String])
-> Map String ByteString
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String ByteString -> [String]
forall k a. Map k a -> [k]
M.keys (Map String ByteString -> Bool) -> Map String ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ Map String ByteString
files) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
    NewPrettyException -> RIO env ()
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (NewPrettyException -> RIO env ())
-> NewPrettyException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ TemplateName -> StyleDoc -> NewPrettyException
TemplateInvalid
      TemplateName
template
      (String -> StyleDoc
flow String
"the template does not contain a Cabal or package.yaml file.")

    -- Apply Mustache templating to a single file within the project template.

  let applyMustache :: ByteString -> m (ByteString, Set String)
applyMustache ByteString
bytes
        -- Workaround for performance problems with mustache and

        -- large files, applies to Yesod templates with large

        -- bootstrap CSS files. See

        -- https://github.com/commercialhaskell/stack/issues/4133.

        | ByteString -> Int64
LB.length ByteString
bytes Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
50000
        , Right Text
text <- ByteString -> Either UnicodeException Text
TLE.decodeUtf8' ByteString
bytes = do
            let etemplateCompiled :: Either ParseError Template
etemplateCompiled =
                  String -> Text -> Either ParseError Template
Mustache.compileTemplate (Text -> String
T.unpack (TemplateName -> Text
templateName TemplateName
template)) (Text -> Either ParseError Template)
-> Text -> Either ParseError Template
forall a b. (a -> b) -> a -> b
$ Text -> Text
TL.toStrict Text
text
            Template
templateCompiled <- case Either ParseError Template
etemplateCompiled of
              Left ParseError
e -> NewPrettyException -> m Template
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (NewPrettyException -> m Template)
-> NewPrettyException -> m Template
forall a b. (a -> b) -> a -> b
$ TemplateName -> StyleDoc -> NewPrettyException
TemplateInvalid
                TemplateName
template
                (  String -> StyleDoc
flow String
"Stack encountered the following error:"
                StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
                   -- Text.Parsec.Error.ParseError is not an instance

                   -- of Control.Exception.

                StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
string (ParseError -> String
forall a. Show a => a -> String
show ParseError
e)
                )
              Right Template
t -> Template -> m Template
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Template
t
            let ([SubstitutionError]
substitutionErrors, Text
applied) =
                  Template -> Map Text Text -> ([SubstitutionError], Text)
forall k.
ToMustache k =>
Template -> k -> ([SubstitutionError], Text)
Mustache.checkedSubstitute Template
templateCompiled Map Text Text
context
                missingKeys :: Set String
missingKeys =
                  [String] -> Set String
forall a. Ord a => [a] -> Set a
S.fromList ([String] -> Set String) -> [String] -> Set String
forall a b. (a -> b) -> a -> b
$ (SubstitutionError -> [String]) -> [SubstitutionError] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SubstitutionError -> [String]
onlyMissingKeys [SubstitutionError]
substitutionErrors
            (ByteString, Set String) -> m (ByteString, Set String)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> ByteString
LB.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
applied, Set String
missingKeys)

        -- Too large or too binary

        | Bool
otherwise = (ByteString, Set String) -> m (ByteString, Set String)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString
bytes, Set String
forall a. Set a
S.empty)

      -- Accumulate any missing keys as the file is processed

      processFile :: Set String
-> (String, ByteString)
-> m (Set String, (Path Abs File, ByteString))
processFile Set String
mks (String
fpOrig, ByteString
bytes) = do
        -- Apply the mustache template to the filenames as well, so that we

        -- can have file names depend on the project name.

        (ByteString
fp, Set String
mks1) <- ByteString -> m (ByteString, Set String)
forall {m :: * -> *}.
MonadThrow m =>
ByteString -> m (ByteString, Set String)
applyMustache (ByteString -> m (ByteString, Set String))
-> ByteString -> m (ByteString, Set String)
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TLE.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> Text
TL.pack String
fpOrig
        Path Rel File
path <- String -> m (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (String -> m (Path Rel File)) -> String -> m (Path Rel File)
forall a b. (a -> b) -> a -> b
$ Text -> String
TL.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
TLE.decodeUtf8 ByteString
fp
        (ByteString
bytes', Set String
mks2) <- ByteString -> m (ByteString, Set String)
forall {m :: * -> *}.
MonadThrow m =>
ByteString -> m (ByteString, Set String)
applyMustache ByteString
bytes
        (Set String, (Path Abs File, ByteString))
-> m (Set String, (Path Abs File, ByteString))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set String
mks Set String -> Set String -> Set String
forall a. Semigroup a => a -> a -> a
<> Set String
mks1 Set String -> Set String -> Set String
forall a. Semigroup a => a -> a -> a
<> Set String
mks2, (Path Abs Dir
dir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
path, ByteString
bytes'))

  (Set String
missingKeys, [(Path Abs File, ByteString)]
results) <- (Set String
 -> (String, ByteString)
 -> RIO env (Set String, (Path Abs File, ByteString)))
-> Set String
-> [(String, ByteString)]
-> RIO env (Set String, [(Path Abs File, ByteString)])
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> m (a, c)) -> a -> [b] -> m (a, [c])
mapAccumLM Set String
-> (String, ByteString)
-> RIO env (Set String, (Path Abs File, ByteString))
forall {m :: * -> *}.
MonadThrow m =>
Set String
-> (String, ByteString)
-> m (Set String, (Path Abs File, ByteString))
processFile Set String
forall a. Set a
S.empty (Map String ByteString -> [(String, ByteString)]
forall k a. Map k a -> [(k, a)]
M.toList Map String ByteString
files)
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Set String -> Bool
forall a. Set a -> Bool
S.null Set String
missingKeys) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
    StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyNote (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
      Set String -> Path Abs File -> StyleDoc
missingParameters
        Set String
missingKeys
        (Config -> Path Abs File
configUserConfigPath Config
config)
  Map (Path Abs File) ByteString
-> RIO env (Map (Path Abs File) ByteString)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map (Path Abs File) ByteString
 -> RIO env (Map (Path Abs File) ByteString))
-> Map (Path Abs File) ByteString
-> RIO env (Map (Path Abs File) ByteString)
forall a b. (a -> b) -> a -> b
$ [(Path Abs File, ByteString)] -> Map (Path Abs File) ByteString
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Path Abs File, ByteString)]
results
 where
  onlyMissingKeys :: SubstitutionError -> [String]
onlyMissingKeys (Mustache.VariableNotFound [Text]
ks) = (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack [Text]
ks
  onlyMissingKeys SubstitutionError
_ = []

  mapAccumLM :: Monad m => (a -> b -> m(a, c)) -> a -> [b] -> m(a, [c])
  mapAccumLM :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> m (a, c)) -> a -> [b] -> m (a, [c])
mapAccumLM a -> b -> m (a, c)
_ a
a [] = (a, [c]) -> m (a, [c])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a, [])
  mapAccumLM a -> b -> m (a, c)
f a
a (b
x:[b]
xs) = do
    (a
a', c
c) <- a -> b -> m (a, c)
f a
a b
x
    (a
a'', [c]
cs) <- (a -> b -> m (a, c)) -> a -> [b] -> m (a, [c])
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> m (a, c)) -> a -> [b] -> m (a, [c])
mapAccumLM a -> b -> m (a, c)
f a
a' [b]
xs
    (a, [c]) -> m (a, [c])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a'', c
cc -> [c] -> [c]
forall a. a -> [a] -> [a]
:[c]
cs)

  missingParameters :: Set String -> Path Abs File -> StyleDoc
  missingParameters :: Set String -> Path Abs File -> StyleDoc
missingParameters Set String
missingKeys Path Abs File
userConfigPath =
       [StyleDoc] -> StyleDoc
fillSep
         ( String -> StyleDoc
flow String
"The following parameters were needed by the template but \
                \not provided:"
         StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: Maybe Style -> Bool -> [StyleDoc] -> [StyleDoc]
forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList Maybe Style
forall a. Maybe a
Nothing Bool
False
             ((String -> StyleDoc) -> [String] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map String -> StyleDoc
toStyleDoc (Set String -> [String]
forall a. Set a -> [a]
S.toList Set String
missingKeys))
         )
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ String -> StyleDoc
flow String
"You can provide them in Stack's global YAML configuration \
                \file"
         , StyleDoc
"(" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
userConfigPath StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
")"
         , StyleDoc
"like this:"
         ]
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"templates:"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"  params:"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
vsep
         ( (String -> StyleDoc) -> [String] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map
             (\String
key -> StyleDoc
"    " StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
forall a. IsString a => String -> a
fromString String
key StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
": value")
             (Set String -> [String]
forall a. Set a -> [a]
S.toList Set String
missingKeys)
         )
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"Or you can pass each one on the command line as parameters \
            \like this:"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> Style -> StyleDoc -> StyleDoc
style Style
Shell
         ( [StyleDoc] -> StyleDoc
fillSep
             [ String -> StyleDoc
flow String
"stack new"
             , String -> StyleDoc
forall a. IsString a => String -> a
fromString (PackageName -> String
packageNameString PackageName
project)
             , String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (TemplateName -> Text
templateName TemplateName
template)
             , [StyleDoc] -> StyleDoc
hsep ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$
                 (String -> StyleDoc) -> [String] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map
                   ( \String
key ->
                       [StyleDoc] -> StyleDoc
fillSep [ StyleDoc
"-p"
                               , StyleDoc
"\"" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
forall a. IsString a => String -> a
fromString String
key StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":value\""
                               ]
                   )
                   (Set String -> [String]
forall a. Set a -> [a]
S.toList Set String
missingKeys)
             ]
         )
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
   where
    toStyleDoc :: String -> StyleDoc
    toStyleDoc :: String -> StyleDoc
toStyleDoc = String -> StyleDoc
forall a. IsString a => String -> a
fromString

-- | Check if we're going to overwrite any existing files.

checkForOverwrite ::
     (MonadIO m, MonadThrow m)
  => Text
  -> [Path Abs File]
  -> m ()
checkForOverwrite :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Text -> [Path Abs File] -> m ()
checkForOverwrite Text
name [Path Abs File]
files = do
  [Path Abs File]
overwrites <- (Path Abs File -> m Bool) -> [Path Abs File] -> m [Path Abs File]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM Path Abs File -> m Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist [Path Abs File]
files
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Path Abs File] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Path Abs File]
overwrites) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    NewPrettyException -> m ()
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (NewPrettyException -> m ()) -> NewPrettyException -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> [Path Abs File] -> NewPrettyException
AttemptedOverwrites Text
name [Path Abs File]
overwrites

-- | Write files to the new project directory.

writeTemplateFiles ::
     MonadIO m
  => Map (Path Abs File) LB.ByteString
  -> m ()
writeTemplateFiles :: forall (m :: * -> *).
MonadIO m =>
Map (Path Abs File) ByteString -> m ()
writeTemplateFiles Map (Path Abs File) ByteString
files =
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
  [(Path Abs File, ByteString)]
-> ((Path Abs File, ByteString) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_
    (Map (Path Abs File) ByteString -> [(Path Abs File, ByteString)]
forall k a. Map k a -> [(k, a)]
M.toList Map (Path Abs File) ByteString
files)
    (\(Path Abs File
fp,ByteString
bytes) ->
      do Path Abs Dir -> IO ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
fp)
         Path Abs File -> Builder -> IO ()
forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
fp (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
lazyByteString ByteString
bytes)

-- | Run any initialization functions, such as Git.

runTemplateInits :: HasConfig env => Path Abs Dir -> RIO env ()
runTemplateInits :: forall env. HasConfig env => Path Abs Dir -> RIO env ()
runTemplateInits Path Abs Dir
dir = do
  Config
config <- Getting Config env Config -> RIO env Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL
  case Config -> Maybe SCM
configScmInit Config
config of
    Maybe SCM
Nothing -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just SCM
Git -> String -> RIO env () -> RIO env ()
forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
String -> m a -> m a
withWorkingDir (Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
dir) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
      RIO env () -> (SomeException -> RIO env ()) -> RIO env ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
catchAny
        (String
-> [String] -> (ProcessConfig () () () -> RIO env ()) -> RIO env ()
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
String -> [String] -> (ProcessConfig () () () -> m a) -> m a
proc String
"git" [String
"init"] ProcessConfig () () () -> RIO env ()
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_)
        ( \SomeException
_ -> StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
                  [StyleDoc] -> StyleDoc
fillSep
                    [ String -> StyleDoc
flow String
"Stack failed to run a"
                    , Style -> StyleDoc -> StyleDoc
style Style
Shell (String -> StyleDoc
flow String
"git init")
                    , String -> StyleDoc
flow String
"command. Ignoring..."
                    ]
        )

--------------------------------------------------------------------------------

-- Defaults


-- | The default service to use to download templates.

defaultRepoService :: RepoService
defaultRepoService :: RepoService
defaultRepoService = RepoService
GitHub