{-# LANGUAGE NoImplicitPrelude         #-}
{-# LANGUAGE ConstraintKinds           #-}
{-# LANGUAGE DeriveDataTypeable        #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE StandaloneDeriving        #-}

-- | Create new a new project directory populated with a basic working

-- project.


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

import           Control.Monad.Trans.Writer.Strict
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
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
import           Data.Time.Clock
import           Network.HTTP.StackClient
                   ( HttpException (..), HttpExceptionContent (..)
                   , Response (..), VerifiedDownloadException (..)
                   , getResponseBody, httpLbs, mkDownloadRequest, notFound404
                   , parseRequest, parseUrlThrow, setForceDownload
                   , setGitHubHeaders, setRequestCheckStatus
                   , verifiedDownloadWithProgress
                   )
import           Path
import           Path.IO
import           RIO.Process
import           Stack.Constants
import           Stack.Constants.Config
import           Stack.Prelude
import           Stack.Types.Config
import           Stack.Types.TemplateName
import qualified Text.Mustache as Mustache
import qualified Text.Mustache.Render as Mustache
import           Text.ProjectTemplate

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

-- 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]
    | DownloadTemplatesHelpFailed !HttpException
    | TemplatesHelpEncodingInvalid !String !UnicodeException
    deriving Typeable

deriving instance Show NewPrettyException

instance Pretty NewPrettyException where
    pretty :: NewPrettyException -> StyleDoc
pretty (ProjectDirAlreadyExists String
name Path Abs Dir
path) =
        StyleDoc
"[S-2135]"
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        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 (forall a. IsString a => String -> a
fromString String
name) forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
             , String -> StyleDoc
flow String
"as the directory"
             , Style -> StyleDoc -> StyleDoc
style Style
Dir (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]"
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        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 (forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Text
name)
             , StyleDoc
"from"
             , Style -> StyleDoc -> StyleDoc
style Style
Url (forall a. IsString a => String -> a
fromString String
url) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
             ]
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
        forall a. Semigroup a => a -> a -> a
<> ( if Bool
isNotFound
                then    String -> StyleDoc
flow String
"Please check that the template exists at that \
                             \location."
                     forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
                else forall a. Monoid a => a
mempty
           )
        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:"
                         forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
                         forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (forall a. Show a => a -> String
show Request
req)
                         forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
                         forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"and the content of the error was:"
                         forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
                         forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (forall a. Show a => a -> String
show HttpExceptionContent
content)
                  isNotFound404 :: Bool
isNotFound404 = case HttpExceptionContent
content of
                                    StatusCodeException Response ()
res ByteString
_ ->
                                      forall body. Response body -> Status
responseStatus Response ()
res 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 (forall a. IsString a => String -> a
fromString String
url')
                           , String -> StyleDoc
flow String
"was considered invalid because"
                           , forall a. IsString a => String -> a
fromString String
reason 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:"
                            forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
                            forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (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]"
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        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 (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ TemplateName -> Text
templateName TemplateName
name)
             , StyleDoc
"from"
             , Style -> StyleDoc -> StyleDoc
style Style
File (forall a. Pretty a => a -> StyleDoc
pretty Path b File
path) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
             ]
    pretty (ExtractTemplateFailed TemplateName
name Path b File
path String
err) =
        StyleDoc
"[S-9582]"
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        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 (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ TemplateName -> Text
templateName TemplateName
name)
             , StyleDoc
"at"
             , Style -> StyleDoc -> StyleDoc
style Style
File (forall a. Pretty a => a -> StyleDoc
pretty Path b File
path) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
             ]
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
        forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"While extracting, Stack encountered the following error:"
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
        forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
string String
err
    pretty (TemplateInvalid TemplateName
name StyleDoc
why) =
        StyleDoc
"[S-9490]"
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        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 (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ TemplateName -> Text
templateName TemplateName
name) forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
             , StyleDoc
"as"
             , StyleDoc
why
             ]
    pretty (MagicPackageNameInvalid String
name) =
        StyleDoc
"[S-5682]"
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        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 (forall a. IsString a => String -> a
fromString String
name) forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
             , String -> StyleDoc
flow String
"as package"
             , 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."
             ]
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
        forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
             ( String -> StyleDoc
flow String
"The names blocked by Stack are:"
             forall a. a -> [a] -> [a]
: forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList forall a. Maybe a
Nothing Bool
False
                 ( forall a b. (a -> b) -> [a] -> [b]
map PackageName -> StyleDoc
toStyleDoc (forall a. Ord a => [a] -> [a]
L.sort forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
S.toList Set PackageName
wiredInPackages)
                 )
             )
      where
        toStyleDoc :: PackageName -> StyleDoc
        toStyleDoc :: PackageName -> StyleDoc
toStyleDoc = forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString
    pretty (AttemptedOverwrites Text
name [Path Abs File]
fps) =
        StyleDoc
"[S-3113]"
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        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 (forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Text
name) forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
             , String -> StyleDoc
flow String
"as it would create files that already exist."
             ]
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
        forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"The template would create the following existing files:"
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList (forall a b. (a -> b) -> [a] -> [b]
map (Style -> StyleDoc -> StyleDoc
style Style
File forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> StyleDoc
pretty) [Path Abs File]
fps)
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
        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."
             ]
    pretty (DownloadTemplatesHelpFailed HttpException
err) =
        StyleDoc
"[S-8143]"
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
             [ String -> StyleDoc
flow String
"Stack failed to download the help for"
             , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"stack templates" forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
             ]
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
        forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"While downloading, Stack encountered the following error:"
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
        forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
string (forall e. Exception e => e -> String
displayException HttpException
err)
    pretty (TemplatesHelpEncodingInvalid String
url UnicodeException
err) =
        StyleDoc
"[S-6670]"
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
             [ String -> StyleDoc
flow String
"Stack failed to decode the help for"
             , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"stack templates"
             , String -> StyleDoc
flow String
"downloaded from"
             , Style -> StyleDoc -> StyleDoc
style Style
Url (forall a. IsString a => String -> a
fromString String
url) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
             ]
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
        forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"While decoding, Stack encountered the following error:"
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
        forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
string (forall e. Exception e => e -> String
displayException UnicodeException
err)


instance Exception NewPrettyException

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

-- Main project creation


-- | Options for creating a new project.

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 -> 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.

    }

-- | 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
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PackageName
project forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Set PackageName
wiredInPackages) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException forall a b. (a -> b) -> a -> b
$ String -> NewPrettyException
MagicPackageNameInvalid String
projectName
    Path Abs Dir
pwd <- forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
    Path Abs Dir
absDir <- if Bool
bare then forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs Dir
pwd
                      else do Path Rel Dir
relDir <- forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir (PackageName -> String
packageNameString PackageName
project)
                              forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Path Abs Dir
pwd forall b t. Path b Dir -> Path Rel t -> Path b t
</>) (forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Rel Dir
relDir)
    Bool
exists <- forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist Path Abs Dir
absDir
    Maybe TemplateName
configTemplate <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Config -> Maybe TemplateName
configDefaultTemplate
    let template :: TemplateName
template = forall a. a -> Maybe a -> a
fromMaybe TemplateName
defaultTemplateName forall a b. (a -> b) -> a -> b
$ 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 forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException forall a b. (a -> b) -> a -> b
$
                 String -> Path Abs Dir -> NewPrettyException
ProjectDirAlreadyExists String
projectName Path Abs Dir
absDir
        else do
            Text
templateText <- forall env.
HasConfig env =>
TemplateName -> (TemplateFrom -> RIO env ()) -> RIO env Text
loadTemplate TemplateName
template (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 <-
                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
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
forceOverwrite Bool -> Bool -> Bool
&& Bool
bare) forall a b. (a -> b) -> a -> b
$
                forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Text -> [Path Abs File] -> m ()
checkForOverwrite (TemplateName -> Text
templateName TemplateName
template) (forall k a. Map k a -> [k]
M.keys Map (Path Abs File) ByteString
files)
            forall (m :: * -> *).
MonadIO m =>
Map (Path Abs File) ByteString -> m ()
writeTemplateFiles Map (Path Abs File) ByteString
files
            forall env. HasConfig env => Path Abs Dir -> RIO env ()
runTemplateInits Path Abs Dir
absDir
            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  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
                      (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ TemplateName -> Text
templateName TemplateName
template)
                  , String -> StyleDoc
flow String
"to create project"
                  , Style -> StyleDoc -> StyleDoc
style Style
Current (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"
                                  , Style -> StyleDoc -> StyleDoc
style Style
Dir (forall a. Pretty a => a -> StyleDoc
pretty forall a b. (a -> b) -> a -> b
$ forall b. Path b Dir -> Path Rel Dir
dirname Path b Dir
absDir)
                                  ]
                       )
                    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 <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 ->
            forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch
                (do Text
f <- 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
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
f)
                (\(PrettyException
e :: PrettyException) -> do
                      case String -> Maybe TemplateDownloadSettings
relSettings String
rawParam of
                        Just TemplateDownloadSettings
settings -> do
                          let url :: String
url = TemplateDownloadSettings -> String
tplDownloadUrl TemplateDownloadSettings
settings
                              extract :: ByteString -> Either String Text
extract = TemplateDownloadSettings -> ByteString -> Either String Text
tplExtract TemplateDownloadSettings
settings
                          String
-> (ByteString -> Either String Text)
-> Path Abs File
-> RIO env Text
downloadTemplate String
url ByteString -> Either String Text
extract (Path Abs Dir
templateDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFile)
                        Maybe TemplateDownloadSettings
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM PrettyException
e
                )
        RepoPath RepoTemplatePath
rtp -> do
            let settings :: TemplateDownloadSettings
settings = RepoTemplatePath -> 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
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Opening local template: \"" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (forall b t. Path b t -> String
toFilePath Path b File
path)
                                                forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\"")
        Bool
exists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path b File
path
        if Bool
exists
            then do
                ByteString
bs <- forall (m :: * -> *). MonadIO m => String -> m ByteString
readFileBinary (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 -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException forall a b. (a -> b) -> a -> b
$
                        forall b.
TemplateName -> Path b File -> String -> NewPrettyException
ExtractTemplateFailed TemplateName
name Path b File
path String
err
                    Right Text
template ->
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
template
            else forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException forall a b. (a -> b) -> a -> b
$
                forall b. TemplateName -> Path b File -> NewPrettyException
LoadTemplateFailed TemplateName
name Path b File
path

    relSettings :: String -> Maybe TemplateDownloadSettings
    relSettings :: String -> Maybe TemplateDownloadSettings
relSettings String
req = do
        RepoTemplatePath
rtp <- RepoService -> Text -> Maybe RepoTemplatePath
parseRepoPathWithService RepoService
defaultRepoService (String -> Text
T.pack String
req)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (RepoTemplatePath -> 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
            rel :: Path Rel File
rel = forall a. a -> Maybe a -> a
fromMaybe Path Rel File
backupUrlRelPath (forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile String
url)
        String
-> (ByteString -> Either String Text)
-> Path Abs File
-> RIO env Text
downloadTemplate String
url (TemplateDownloadSettings -> ByteString -> Either String Text
tplExtract TemplateDownloadSettings
settings) (Path Abs Dir
templateDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
rel)

    downloadTemplate :: String
                     -> (ByteString
                     -> Either String Text)
                     -> Path Abs File
                     -> RIO env Text
    downloadTemplate :: String
-> (ByteString -> Either String Text)
-> Path Abs File
-> RIO env Text
downloadTemplate String
url ByteString -> Either String Text
extract Path Abs File
path = do
        Request
req <- forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
url
        let dReq :: DownloadRequest
dReq = Bool -> DownloadRequest -> DownloadRequest
setForceDownload Bool
True forall a b. (a -> b) -> a -> b
$
                       Request -> DownloadRequest
mkDownloadRequest (Request -> Request
setRequestCheckStatus Request
req)
        TemplateFrom -> RIO env ()
logIt TemplateFrom
RemoteTemp
        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 forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> String
toFilePath Path Abs File
path
               Bool
res <- forall env.
HasTerm env =>
DownloadRequest
-> Path Abs File -> Text -> Maybe Int -> RIO env Bool
verifiedDownloadWithProgress DownloadRequest
dReq Path Abs File
path Text
label forall a. Maybe a
Nothing
               if Bool
res
                 then forall (m :: * -> *) env.
(MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) =>
Utf8Builder -> m ()
logStickyDone (Utf8Builder
"Downloaded " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
label forall a. Semigroup a => a -> a -> a
<> Utf8Builder
".")
                 else 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)
        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 <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
path

      if Bool
exists
        then 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 forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException forall a b. (a -> b) -> a -> b
$
                 Text -> String -> VerifiedDownloadException -> NewPrettyException
DownloadTemplateFailed (TemplateName -> Text
templateName TemplateName
name) String
url VerifiedDownloadException
exception

data TemplateDownloadSettings = TemplateDownloadSettings
  { TemplateDownloadSettings -> String
tplDownloadUrl :: String
  , TemplateDownloadSettings -> ByteString -> Either String Text
tplExtract :: ByteString -> Either String Text
  }

eitherByteStringToText :: ByteString -> Either String Text
eitherByteStringToText :: ByteString -> Either String Text
eitherByteStringToText = forall a1 a2 b. (a1 -> a2) -> Either a1 b -> Either a2 b
mapLeft forall a. Show a => a -> String
show 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
  , tplExtract :: ByteString -> Either String Text
tplExtract = ByteString -> Either String Text
eitherByteStringToText
  }

-- | Construct a URL for downloading from a repo.

settingsFromRepoTemplatePath :: RepoTemplatePath -> TemplateDownloadSettings
settingsFromRepoTemplatePath :: RepoTemplatePath -> TemplateDownloadSettings
settingsFromRepoTemplatePath (RepoTemplatePath RepoService
GitHub Text
user Text
name) =
    -- T.concat ["https://raw.githubusercontent.com", "/", user, "/stack-templates/master/", name]

    TemplateDownloadSettings
    { tplDownloadUrl :: String
tplDownloadUrl = 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
          ]
    , tplExtract :: ByteString -> Either String Text
tplExtract = \ByteString
bs -> do
        Value
decodedJson <- 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) <- 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 (forall a. Eq a => a -> a -> Bool
/= Char
'\n')
                       ByteString
bsContent <- ByteString -> Either String ByteString
B64.decode forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8 (Text -> Text
noNewlines Text
content)
                       forall a1 a2 b. (a1 -> a2) -> Either a1 b -> Either a2 b
mapLeft forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
bsContent
          Value
_ ->
            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) =
    String -> TemplateDownloadSettings
asIsFromUrl forall a b. (a -> b) -> a -> b
$ 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) =
    String -> TemplateDownloadSettings
asIsFromUrl forall a b. (a -> b) -> a -> b
$ 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 <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
    Text
currentYear <- do
      UTCTime
now <- 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)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Year
year
    let context :: Map Text Text
context = 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 = Text -> Text -> Text -> Text
T.replace Text
"-" Text
"_" forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
project
            nameAsModule :: Text
nameAsModule = (Char -> Bool) -> Text -> Text
T.filter (forall a. Eq a => a -> a -> Bool
/= Char
' ') forall a b. (a -> b) -> a -> b
$ Text -> Text
T.toTitle forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Text
T.replace Text
"-" Text
" " forall a b. (a -> b) -> a -> b
$
                               String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
project
            nameParams :: Map Text Text
nameParams = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ (Text
"name", String -> Text
T.pack 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 = forall k a. k -> a -> Map k a
M.singleton Text
"year" Text
currentYear
    Map String ByteString
files :: Map FilePath LB.ByteString <-
        forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch
            ( forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$
                  forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Text -> ByteString
T.encodeUtf8 Text
templateText) forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.|
                  forall (m :: * -> *) o.
MonadThrow m =>
(String -> ConduitM ByteString o m ())
-> (Text -> Text) -> ConduitM ByteString o m ()
unpackTemplate forall (m :: * -> *).
MonadWriter (Map String ByteString) m =>
FileReceiver m
receiveMem forall a. a -> a
id
            )
            ( \(ProjectTemplateException
e :: ProjectTemplateException) ->
                  forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException forall a b. (a -> b) -> a -> b
$
                      TemplateName -> StyleDoc -> NewPrettyException
TemplateInvalid TemplateName
template (String -> StyleDoc
string forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> String
displayException ProjectTemplateException
e)
            )
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall k a. Map k a -> Bool
M.null Map String ByteString
files) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException 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" forall a. Eq a => [a] -> [a] -> Bool
`L.isSuffixOf` String
f Bool -> Bool -> Bool
|| String
f forall a. Eq a => a -> a -> Bool
== String
"package.yaml"
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any String -> Bool
isPkgSpec forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [k]
M.keys forall a b. (a -> b) -> a -> b
$ Map String ByteString
files) forall a b. (a -> b) -> a -> b
$
         forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException 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 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)) forall a b. (a -> b) -> a -> b
$ Text -> Text
TL.toStrict Text
text
              Template
templateCompiled <- case Either ParseError Template
etemplateCompiled of
                Left ParseError
e -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException forall a b. (a -> b) -> a -> b
$
                    TemplateName -> StyleDoc -> NewPrettyException
TemplateInvalid
                        TemplateName
template
                        (    String -> StyleDoc
flow String
"Stack encountered the following error:"
                          forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
                             -- Text.Parsec.Error.ParseError is not an instance

                             -- of Control.Exception.

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

          -- Too large or too binary

          | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString
bytes, 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) <- forall {m :: * -> *}.
MonadThrow m =>
ByteString -> m (ByteString, Set String)
applyMustache forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TLE.encodeUtf8 forall a b. (a -> b) -> a -> b
$ String -> Text
TL.pack String
fpOrig
          Path Rel File
path <- forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile forall a b. (a -> b) -> a -> b
$ Text -> String
TL.unpack forall a b. (a -> b) -> a -> b
$ ByteString -> Text
TLE.decodeUtf8 ByteString
fp
          (ByteString
bytes', Set String
mks2) <- forall {m :: * -> *}.
MonadThrow m =>
ByteString -> m (ByteString, Set String)
applyMustache ByteString
bytes
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set String
mks forall a. Semigroup a => a -> a -> a
<> Set String
mks1 forall a. Semigroup a => a -> a -> a
<> Set String
mks2, (Path Abs Dir
dir 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) <- forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> m (a, c)) -> a -> [b] -> m (a, [c])
mapAccumLM forall {m :: * -> *}.
MonadThrow m =>
Set String
-> (String, ByteString)
-> m (Set String, (Path Abs File, ByteString))
processFile forall a. Set a
S.empty (forall k a. Map k a -> [(k, a)]
M.toList Map String ByteString
files)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Set a -> Bool
S.null Set String
missingKeys) forall a b. (a -> b) -> a -> b
$ do
      forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyNote forall a b. (a -> b) -> a -> b
$
        Set String -> Path Abs File -> StyleDoc
missingParameters
          Set String
missingKeys
          (Config -> Path Abs File
configUserConfigPath Config
config)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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) = 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 [] = 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) <- 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
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a'', c
cforall 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:"
             forall a. a -> [a] -> [a]
: forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList
                 forall a. Maybe a
Nothing
                 Bool
False
                 (forall a b. (a -> b) -> [a] -> [b]
map String -> StyleDoc
toStyleDoc (forall a. Set a -> [a]
S.toList Set String
missingKeys))
             )
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
        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
"(" forall a. Semigroup a => a -> a -> a
<> Style -> StyleDoc -> StyleDoc
style Style
File (forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
userConfigPath) forall a. Semigroup a => a -> a -> a
<> StyleDoc
")"
             , StyleDoc
"like this:"
             ]
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
"templates:"
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
"  params:"
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
vsep
             ( forall a b. (a -> b) -> [a] -> [b]
map
                 (\String
key -> StyleDoc
"    " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString String
key forall a. Semigroup a => a -> a -> a
<> StyleDoc
": value")
                 (forall a. Set a -> [a]
S.toList Set String
missingKeys)
             )
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
        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:"
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
        forall a. Semigroup a => a -> a -> a
<> Style -> StyleDoc -> StyleDoc
style Style
Shell
             ( [StyleDoc] -> StyleDoc
fillSep
                 [ String -> StyleDoc
flow String
"stack new"
                 , forall a. IsString a => String -> a
fromString (PackageName -> String
packageNameString PackageName
project)
                 , forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (TemplateName -> Text
templateName TemplateName
template)
                 , [StyleDoc] -> StyleDoc
hsep forall a b. (a -> b) -> a -> b
$
                     forall a b. (a -> b) -> [a] -> [b]
map
                       ( \String
key ->
                           [StyleDoc] -> StyleDoc
fillSep [ StyleDoc
"-p"
                                   , StyleDoc
"\"" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString String
key forall a. Semigroup a => a -> a -> a
<> StyleDoc
":value\""
                                   ]
                       )
                       (forall a. Set a -> [a]
S.toList Set String
missingKeys)
                 ]
             )
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      where
        toStyleDoc :: String -> StyleDoc
        toStyleDoc :: String -> StyleDoc
toStyleDoc = 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 <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist [Path Abs File]
files
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Path Abs File]
overwrites) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException 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 =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_
        (forall k a. Map k a -> [(k, a)]
M.toList Map (Path Abs File) ByteString
files)
        (\(Path Abs File
fp,ByteString
bytes) ->
              do forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (forall b t. Path b t -> Path b Dir
parent Path Abs File
fp)
                 forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
fp 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 <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
    case Config -> Maybe SCM
configScmInit Config
config of
        Maybe SCM
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just SCM
Git -> forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
String -> m a -> m a
withWorkingDir (forall b t. Path b t -> String
toFilePath Path Abs Dir
dir) forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
catchAny
                (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"] forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_)
                ( \SomeException
_ -> forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn 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..."
                              ]
                )

-- | Display help for the templates command.

templatesHelp :: HasLogFunc env => RIO env ()
templatesHelp :: forall env. HasLogFunc env => RIO env ()
templatesHelp = do
  let url :: String
url = String
defaultTemplatesHelpUrl
  Request
req <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Request -> Request
setGitHubHeaders (forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow String
url)
  Response ByteString
resp <- forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch
    (forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
httpLbs Request
req)
    (forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyExceptionforall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpException -> NewPrettyException
DownloadTemplatesHelpFailed)
  case ByteString -> Either UnicodeException Text
decodeUtf8' forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LB.toStrict forall a b. (a -> b) -> a -> b
$ forall a. Response a -> a
getResponseBody Response ByteString
resp of
    Left UnicodeException
err -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException forall a b. (a -> b) -> a -> b
$ String -> UnicodeException -> NewPrettyException
TemplatesHelpEncodingInvalid String
url UnicodeException
err
    Right Text
txt -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Utf8Builder
display Text
txt

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

-- Defaults


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

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

-- | Default web URL to get the `stack templates` help output.

defaultTemplatesHelpUrl :: String
defaultTemplatesHelpUrl :: String
defaultTemplatesHelpUrl =
    String
"https://raw.githubusercontent.com/commercialhaskell/stack-templates/master/STACK_HELP.md"