{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE NoFieldSelectors    #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings   #-}

{-|
Module      : Stack.New
Description : Types and functions related to Stack's @new@ command.
License     : BSD-3-Clause

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

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

import           Control.Monad.Extra ( whenJust )
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
                   ( allWiredInPackages, altGitHubTokenEnvVar, backupUrlRelPath
                   , gitHubBasicAuthType, gitHubTokenEnvVar, stackDotYaml
                   )
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 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
forall a. IsString a => PackageName -> a
fromPackageName [PackageName]
sortedWiredInPackages :: [StyleDoc])
         )
   where
    sortedWiredInPackages :: [PackageName]
sortedWiredInPackages = [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
allWiredInPackages
  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
projectName  :: PackageName
    -- ^ Name of the project to create.

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

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

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

  , NewOpts -> Map Text Text
nonceParams  :: 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
    dir <- NewOpts -> Bool -> RIO Config (Path Abs Dir)
forall env.
HasConfig env =>
NewOpts -> Bool -> RIO env (Path Abs Dir)
new NewOpts
newOpts InitOpts
initOpts.forceOverwrite
    exists <- doesFileExist $ dir </> stackDotYaml
    when (newOpts.init && (initOpts.forceOverwrite || not exists)) $ do
      go <- view globalOptsL
      initProject dir initOpts go.snapshot

-- | 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
allWiredInPackages) (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
  pwd <- RIO env (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
  absDir <- if bare
              then pure pwd
              else do relDir <- parseRelDir (packageNameString project)
                      pure (pwd </> relDir)
  exists <- doesDirExist absDir
  configTemplate <- view $ configL . to (.defaultTemplate)
  let 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 exists && not bare
    then prettyThrowM $ ProjectDirAlreadyExists projectName absDir
    else do
      templateText <- loadTemplate template (logUsing absDir template)
      files <-
        applyTemplate
          project
          template
          opts.nonceParams
          absDir
          templateText
      when (not forceOverwrite && bare) $
        checkForOverwrite (templateName template) (M.keys files)
      writeTemplateFiles files
      runTemplateInits absDir
      pure absDir
 where
  cliOptionTemplate :: Maybe TemplateName
cliOptionTemplate = NewOpts
opts.template
  project :: PackageName
project = NewOpts
opts.projectName
  projectName :: String
projectName = PackageName -> String
packageNameString PackageName
project
  bare :: Bool
bare = NewOpts
opts.createBare
  logUsing :: Path Abs Dir -> TemplateName -> TemplateFrom -> RIO env ()
logUsing Path Abs 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 -> RIO env ()
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 Abs Dir -> Path Rel Dir
forall b. Path b Dir -> Path Rel Dir
dirname Path Abs 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
  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 templatePath 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 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
            logIt LocalTemp
            pure f)
        ( \(PrettyException
e :: PrettyException) -> do
            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. (HasCallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM PrettyException
e) (String -> Maybe (RIO env TemplateDownloadSettings)
relSettings String
rawParam)
            let url = TemplateDownloadSettings
settings.downloadUrl
                mBasicAuth = TemplateDownloadSettings
settings.basicAuth
                extract = TemplateDownloadSettings
settings.extract
            downloadTemplate url mBasicAuth extract (templateDir </> relFile)
        )
    RepoPath RepoTemplatePath
rtp -> do
      settings <- RepoTemplatePath -> RIO env TemplateDownloadSettings
forall env.
HasTerm env =>
RepoTemplatePath -> RIO env TemplateDownloadSettings
settingsFromRepoTemplatePath RepoTemplatePath
rtp
      downloadFromUrl settings 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
"\""
    exists <- Path b File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path b File
path
    if exists
      then do
        bs <- readFileBinary (toFilePath path) --readFileUtf8 (toFilePath path)

        case extract 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 prettyThrowM $ LoadTemplateFailed name path

  relSettings :: String -> Maybe (RIO env TemplateDownloadSettings)
  relSettings :: String -> Maybe (RIO env TemplateDownloadSettings)
relSettings String
req = do
    rtp <- RepoService -> Text -> Maybe RepoTemplatePath
parseRepoPathWithService RepoService
defaultRepoService (String -> Text
T.pack String
req)
    pure (settingsFromRepoTemplatePath 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
settings.downloadUrl
        mBasicAuth :: Maybe (ByteString, ByteString)
mBasicAuth = TemplateDownloadSettings
settings.basicAuth
        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
settings.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
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
    req <- String -> RIO env Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
url
    let 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 = 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)
    logIt RemoteTemp
    catch
      ( do let 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
           res <- verifiedDownloadWithProgress dReq path label Nothing
           if res
             then logStickyDone ("Downloaded " <> display label <> ".")
             else logStickyDone "Already downloaded."
      )
      (useCachedVersionOrThrow url path)
    loadLocalFile path 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
    exists <- Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
path

    if exists
      then
        prettyWarn
          ( flow "Tried to download the template but an error was \
                 \found. Using cached local version. It may not be the \
                 \most recent version though."
          )
      else
        prettyThrowM $ DownloadTemplateFailed (templateName name) url exception

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

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

  , TemplateDownloadSettings -> ByteString -> Either String Text
extract :: 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
  { downloadUrl :: String
downloadUrl = String
url
  , basicAuth :: Maybe (ByteString, ByteString)
basicAuth = Maybe (ByteString, ByteString)
forall a. Maybe a
Nothing
  , extract :: ByteString -> Either String Text
extract = 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."
        ]
  mBasicAuth <- do
    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 not (L.null wantGitHubToken)
      then do
         basicAuthMsg gitHubTokenEnvVar
         pure $ Just (gitHubBasicAuthType, fromString wantGitHubToken)
      else do
        wantAltGitHubToken <-
          liftIO $ fromMaybe "" <$> lookupEnv altGitHubTokenEnvVar
        if not (L.null wantAltGitHubToken)
        then do
          basicAuthMsg altGitHubTokenEnvVar
          pure $ Just (gitHubBasicAuthType, fromString wantAltGitHubToken)
        else pure Nothing
  pure TemplateDownloadSettings
    { downloadUrl = concat
        [ "https://api.github.com/repos/"
        , T.unpack user
        , "/stack-templates/contents/"
        , T.unpack name
        ]
    , basicAuth = mBasicAuth
    , extract = \ByteString
bs ->
        ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
eitherDecode (ByteString -> ByteString
LB.fromStrict ByteString
bs) Either String Value
-> (Value -> Either String Text) -> Either String Text
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          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')
            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)
            mapLeft show $ decodeUtf8' 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
    ]
settingsFromRepoTemplatePath (RepoTemplatePath RepoService
Codeberg 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://codeberg.org"
    , String
"/"
    , Text -> String
T.unpack Text
user
    , String
"/stack-templates/raw/"
    , 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 <- 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
  currentYear <- do
    now <- liftIO getCurrentTime
    let (year, _, _) = toGregorian (utctDay now)
    pure $ T.pack . show $ year
  let 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
config.templateParams
        yearParam :: Map Text Text
yearParam = Text -> Text -> Map Text Text
forall k a. k -> a -> Map k a
M.singleton Text
"year" Text
currentYear
  files :: Map FilePath LB.ByteString <-
    catch
      ( execWriterT $ runConduit $
            yield (T.encodeUtf8 templateText) .|
            unpackTemplate receiveMem 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)
      )
  when (M.null files) $
    prettyThrowM $ TemplateInvalid
      template
      (flow "the template does not contain any files.")

  let isPkgSpec String
f = String
".cabal" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isSuffixOf` String
f Bool -> Bool -> Bool
|| String
"package.yaml" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isSuffixOf` String
f
  unless (any isPkgSpec . M.keys $ files) $
    prettyThrowM $ TemplateInvalid
      template
      (flow "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
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
            templateCompiled <- case Either ParseError Template
etemplateCompiled of
              Left ParseError
e -> NewPrettyException -> RIO env Template
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (NewPrettyException -> RIO env Template)
-> NewPrettyException -> RIO env 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 -> RIO env Template
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Template
t
            let (substitutionErrors, applied) =
                  Mustache.checkedSubstitute templateCompiled context
                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
            pure (LB.fromStrict $ encodeUtf8 applied, missingKeys)

        -- Too large or too binary

        | Bool
otherwise = (ByteString, Set String) -> RIO env (ByteString, Set String)
forall a. a -> RIO env 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
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.

        (fp, mks1) <- ByteString -> RIO env (ByteString, Set String)
applyMustache (ByteString -> RIO env (ByteString, Set String))
-> ByteString -> RIO env (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 <- parseRelFile $ TL.unpack $ TLE.decodeUtf8 fp
        (bytes', mks2) <- applyMustache bytes
        pure (mks <> mks1 <> mks2, (dir </> path, bytes'))

  (missingKeys, results) <- mapAccumLM processFile S.empty (M.toList files)
  unless (S.null missingKeys) $
    prettyNote $
      missingParameters
        missingKeys
        config.userGlobalConfigFile
  pure $ M.fromList 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', c) <- a -> b -> m (a, c)
f a
a b
x
    (a'', cs) <- mapAccumLM f a' xs
    pure (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 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"
             , PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName 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
  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
  unless (null overwrites) $
    prettyThrowM $ AttemptedOverwrites name 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 <- 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
  whenJust config.scmInit $ \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 ()
prettyWarnL
            [ 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