{-# 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]"
        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"
             , Style -> StyleDoc -> StyleDoc
style Style
Dir (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
forall a. IsString a => String -> a
fromString (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
forall a. IsString a => String -> a
fromString (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"
             , Style -> StyleDoc -> StyleDoc
style Style
File (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"
             , Style -> StyleDoc -> StyleDoc
style Style
File (Path b File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path b File
path) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
             ]
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"While extracting, Stack encountered the following error:"
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
string String
err
    pretty (TemplateInvalid TemplateName
name StyleDoc
why) =
        StyleDoc
"[S-9490]"
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
             [ String -> StyleDoc
flow String
"Stack failed to use the template"
             , Style -> StyleDoc -> StyleDoc
style Style
Current (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ TemplateName -> Text
templateName TemplateName
name) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
             , StyleDoc
"as"
             , StyleDoc
why
             ]
    pretty (MagicPackageNameInvalid String
name) =
        StyleDoc
"[S-5682]"
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
             [ String -> StyleDoc
flow String
"Stack declined to create a new directory for project"
             , Style -> StyleDoc -> StyleDoc
style Style
Current (String -> StyleDoc
forall a. IsString a => String -> a
fromString String
name) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
             , String -> StyleDoc
flow String
"as package"
             , String -> StyleDoc
forall a. IsString a => String -> a
fromString String
name
             , String -> StyleDoc
flow String
"is 'wired-in' to a version of GHC. That can cause build \
                    \errors."
             ]
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
             ( String -> StyleDoc
flow String
"The names blocked by Stack are:"
             StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: Maybe Style -> Bool -> [StyleDoc] -> [StyleDoc]
forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList Maybe Style
forall a. Maybe a
Nothing Bool
False
                 ( (PackageName -> StyleDoc) -> [PackageName] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map PackageName -> StyleDoc
toStyleDoc ([PackageName] -> [PackageName]
forall a. Ord a => [a] -> [a]
L.sort ([PackageName] -> [PackageName]) -> [PackageName] -> [PackageName]
forall a b. (a -> b) -> a -> b
$ Set PackageName -> [PackageName]
forall a. Set a -> [a]
S.toList Set PackageName
wiredInPackages)
                 )
             )
      where
        toStyleDoc :: PackageName -> StyleDoc
        toStyleDoc :: PackageName -> StyleDoc
toStyleDoc = String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> (PackageName -> String) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString
    pretty (AttemptedOverwrites Text
name [Path Abs File]
fps) =
        StyleDoc
"[S-3113]"
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
             [ String -> StyleDoc
flow String
"Stack declined to apply the template"
             , Style -> StyleDoc -> StyleDoc
style Style
Current (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> (Text -> String) -> Text -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> StyleDoc) -> Text -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text
name) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
             , String -> StyleDoc
flow String
"as it would create files that already exist."
             ]
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"The template would create the following existing files:"
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList ((Path Abs File -> StyleDoc) -> [Path Abs File] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Style -> StyleDoc -> StyleDoc
style Style
File (StyleDoc -> StyleDoc)
-> (Path Abs File -> StyleDoc) -> Path Abs File -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty) [Path Abs File]
fps)
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
             [ StyleDoc
"Use the"
             , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--force"
             , StyleDoc
"flag to ignore this and overwrite those files."
             ]
    pretty (DownloadTemplatesHelpFailed HttpException
err) =
        StyleDoc
"[S-8143]"
        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 help for"
             , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"stack templates" 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 downloading, 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 (HttpException -> String
forall e. Exception e => e -> String
displayException HttpException
err)
    pretty (TemplatesHelpEncodingInvalid String
url UnicodeException
err) =
        StyleDoc
"[S-6670]"
        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 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 (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
<> String -> StyleDoc
flow String
"While decoding, 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 (UnicodeException -> 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
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PackageName
project PackageName -> Set PackageName -> Bool
forall a. Eq a => a -> Set a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Set PackageName
wiredInPackages) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
        PrettyException -> RIO env ()
forall e a. Exception e => e -> RIO env a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (PrettyException -> RIO env ()) -> PrettyException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ NewPrettyException -> PrettyException
forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException (NewPrettyException -> PrettyException)
-> NewPrettyException -> PrettyException
forall a b. (a -> b) -> a -> b
$ String -> NewPrettyException
MagicPackageNameInvalid String
projectName
    Path Abs Dir
pwd <- RIO env (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
    Path Abs Dir
absDir <- if Bool
bare then Path Abs Dir -> RIO env (Path Abs Dir)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs Dir
pwd
                      else do Path Rel Dir
relDir <- String -> RIO env (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir (PackageName -> String
packageNameString PackageName
project)
                              (Path Rel Dir -> Path Abs Dir)
-> RIO env (Path Rel Dir) -> RIO env (Path Abs Dir)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Path Abs Dir
pwd Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</>) (Path Rel Dir -> RIO env (Path Rel Dir)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Rel Dir
relDir)
    Bool
exists <- Path Abs Dir -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist Path Abs Dir
absDir
    Maybe TemplateName
configTemplate <- Getting (Maybe TemplateName) env (Maybe TemplateName)
-> RIO env (Maybe TemplateName)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Maybe TemplateName) env (Maybe TemplateName)
 -> RIO env (Maybe TemplateName))
-> Getting (Maybe TemplateName) env (Maybe TemplateName)
-> RIO env (Maybe TemplateName)
forall a b. (a -> b) -> a -> b
$ (Config -> Const (Maybe TemplateName) Config)
-> env -> Const (Maybe TemplateName) env
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL((Config -> Const (Maybe TemplateName) Config)
 -> env -> Const (Maybe TemplateName) env)
-> ((Maybe TemplateName
     -> Const (Maybe TemplateName) (Maybe TemplateName))
    -> Config -> Const (Maybe TemplateName) Config)
-> Getting (Maybe TemplateName) env (Maybe TemplateName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Config -> Maybe TemplateName)
-> SimpleGetter Config (Maybe TemplateName)
forall s a. (s -> a) -> SimpleGetter s a
to Config -> Maybe TemplateName
configDefaultTemplate
    let template :: TemplateName
template = TemplateName -> Maybe TemplateName -> TemplateName
forall a. a -> Maybe a -> a
fromMaybe TemplateName
defaultTemplateName (Maybe TemplateName -> TemplateName)
-> Maybe TemplateName -> TemplateName
forall a b. (a -> b) -> a -> b
$ [Maybe TemplateName] -> Maybe TemplateName
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [ Maybe TemplateName
cliOptionTemplate
                                                        , Maybe TemplateName
configTemplate
                                                        ]
    if Bool
exists Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
bare
        then PrettyException -> RIO env (Path Abs Dir)
forall e a. Exception e => e -> RIO env a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (PrettyException -> RIO env (Path Abs Dir))
-> PrettyException -> RIO env (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ NewPrettyException -> PrettyException
forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException (NewPrettyException -> PrettyException)
-> NewPrettyException -> PrettyException
forall a b. (a -> b) -> a -> b
$
                 String -> Path Abs Dir -> NewPrettyException
ProjectDirAlreadyExists String
projectName Path Abs Dir
absDir
        else do
            Text
templateText <- TemplateName -> (TemplateFrom -> RIO env ()) -> RIO env Text
forall env.
HasConfig env =>
TemplateName -> (TemplateFrom -> RIO env ()) -> RIO env Text
loadTemplate TemplateName
template (Path Abs Dir -> TemplateName -> TemplateFrom -> RIO env ()
forall {env} {m :: * -> *} {b}.
(HasTerm env, MonadReader env m, MonadIO m) =>
Path b Dir -> TemplateName -> TemplateFrom -> m ()
logUsing Path Abs Dir
absDir TemplateName
template)
            Map (Path Abs File) ByteString
files <-
                PackageName
-> TemplateName
-> Map Text Text
-> Path Abs Dir
-> Text
-> RIO env (Map (Path Abs File) ByteString)
forall env.
HasConfig env =>
PackageName
-> TemplateName
-> Map Text Text
-> Path Abs Dir
-> Text
-> RIO env (Map (Path Abs File) ByteString)
applyTemplate
                    PackageName
project
                    TemplateName
template
                    (NewOpts -> Map Text Text
newOptsNonceParams NewOpts
opts)
                    Path Abs Dir
absDir
                    Text
templateText
            Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
forceOverwrite Bool -> Bool -> Bool
&& Bool
bare) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
                Text -> [Path Abs File] -> RIO env ()
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Text -> [Path Abs File] -> m ()
checkForOverwrite (TemplateName -> Text
templateName TemplateName
template) (Map (Path Abs File) ByteString -> [Path Abs File]
forall k a. Map k a -> [k]
M.keys Map (Path Abs File) ByteString
files)
            Map (Path Abs File) ByteString -> RIO env ()
forall (m :: * -> *).
MonadIO m =>
Map (Path Abs File) ByteString -> m ()
writeTemplateFiles Map (Path Abs File) ByteString
files
            Path Abs Dir -> RIO env ()
forall env. HasConfig env => Path Abs Dir -> RIO env ()
runTemplateInits Path Abs Dir
absDir
            Path Abs Dir -> RIO env (Path Abs Dir)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs Dir
absDir
  where
    cliOptionTemplate :: Maybe TemplateName
cliOptionTemplate = NewOpts -> Maybe TemplateName
newOptsTemplate NewOpts
opts
    project :: PackageName
project = NewOpts -> PackageName
newOptsProjectName NewOpts
opts
    projectName :: String
projectName = PackageName -> String
packageNameString PackageName
project
    bare :: Bool
bare = NewOpts -> Bool
newOptsCreateBare NewOpts
opts
    logUsing :: Path b Dir -> TemplateName -> TemplateFrom -> m ()
logUsing Path b Dir
absDir TemplateName
template TemplateFrom
templateFrom =
        let loading :: StyleDoc
loading = case TemplateFrom
templateFrom of
                          TemplateFrom
LocalTemp -> String -> StyleDoc
flow String
"Loading local"
                          TemplateFrom
RemoteTemp -> StyleDoc
"Downloading"
        in  StyleDoc -> m ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo
              ( [StyleDoc] -> StyleDoc
fillSep
                  [ StyleDoc
loading
                  , StyleDoc
"template"
                  , Style -> StyleDoc -> StyleDoc
style
                      Style
Current
                      (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ TemplateName -> Text
templateName TemplateName
template)
                  , String -> StyleDoc
flow String
"to create project"
                  , Style -> StyleDoc -> StyleDoc
style Style
Current (String -> StyleDoc
forall a. IsString a => String -> a
fromString String
projectName)
                  , StyleDoc
"in"
                  ,    ( if Bool
bare
                           then String -> StyleDoc
flow String
"the current directory"
                           else [StyleDoc] -> StyleDoc
fillSep
                                  [ StyleDoc
"directory"
                                  , Style -> StyleDoc -> StyleDoc
style Style
Dir (Path Rel Dir -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty (Path Rel Dir -> StyleDoc) -> Path Rel Dir -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Path b Dir -> Path Rel Dir
forall b. Path b Dir -> Path Rel Dir
dirname Path b Dir
absDir)
                                  ]
                       )
                    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"..."
                  ]
                )

data TemplateFrom = LocalTemp | RemoteTemp

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

loadTemplate
    :: forall env. HasConfig env
    => TemplateName
    -> (TemplateFrom -> RIO env ())
    -> RIO env Text
loadTemplate :: forall env.
HasConfig env =>
TemplateName -> (TemplateFrom -> RIO env ()) -> RIO env Text
loadTemplate TemplateName
name TemplateFrom -> RIO env ()
logIt = do
    Path Abs Dir
templateDir <- Getting (Path Abs Dir) env (Path Abs Dir) -> RIO env (Path Abs Dir)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Path Abs Dir) env (Path Abs Dir)
 -> RIO env (Path Abs Dir))
-> Getting (Path Abs Dir) env (Path Abs Dir)
-> RIO env (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ (Config -> Const (Path Abs Dir) Config)
-> env -> Const (Path Abs Dir) env
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL((Config -> Const (Path Abs Dir) Config)
 -> env -> Const (Path Abs Dir) env)
-> ((Path Abs Dir -> Const (Path Abs Dir) (Path Abs Dir))
    -> Config -> Const (Path Abs Dir) Config)
-> Getting (Path Abs Dir) env (Path Abs Dir)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Config -> Path Abs Dir) -> SimpleGetter Config (Path Abs Dir)
forall s a. (s -> a) -> SimpleGetter s a
to Config -> Path Abs Dir
templatesDir
    case TemplateName -> TemplatePath
templatePath TemplateName
name of
        AbsPath Path Abs File
absFile ->
            TemplateFrom -> RIO env ()
logIt TemplateFrom
LocalTemp RIO env () -> RIO env Text -> RIO env Text
forall a b. RIO env a -> RIO env b -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Path Abs File -> (ByteString -> Either String Text) -> RIO env Text
forall b.
Path b File -> (ByteString -> Either String Text) -> RIO env Text
loadLocalFile Path Abs File
absFile ByteString -> Either String Text
eitherByteStringToText
        UrlPath String
s -> do
            let settings :: TemplateDownloadSettings
settings = String -> TemplateDownloadSettings
asIsFromUrl String
s
            TemplateDownloadSettings -> Path Abs Dir -> RIO env Text
downloadFromUrl TemplateDownloadSettings
settings Path Abs Dir
templateDir
        RelPath String
rawParam Path Rel File
relFile ->
            RIO env Text -> (PrettyException -> RIO env Text) -> RIO env Text
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch
                (do Text
f <- Path Rel File -> (ByteString -> Either String Text) -> RIO env Text
forall b.
Path b File -> (ByteString -> Either String Text) -> RIO env Text
loadLocalFile Path Rel File
relFile ByteString -> Either String Text
eitherByteStringToText
                    TemplateFrom -> RIO env ()
logIt TemplateFrom
LocalTemp
                    Text -> RIO env Text
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
f)
                (\(PrettyException
e :: PrettyException) -> do
                      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 Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFile)
                        Maybe TemplateDownloadSettings
Nothing -> PrettyException -> RIO env Text
forall e a. Exception e => e -> RIO env a
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
        Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Opening local template: \"" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path b File -> String
forall b t. Path b t -> String
toFilePath Path b File
path)
                                                Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\"")
        Bool
exists <- Path b File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path b File
path
        if Bool
exists
            then do
                ByteString
bs <- String -> RIO env ByteString
forall (m :: * -> *). MonadIO m => String -> m ByteString
readFileBinary (Path b File -> String
forall b t. Path b t -> String
toFilePath Path b File
path) --readFileUtf8 (toFilePath path)

                case ByteString -> Either String Text
extract ByteString
bs of
                    Left String
err -> PrettyException -> RIO env Text
forall e a. Exception e => e -> RIO env a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (PrettyException -> RIO env Text)
-> PrettyException -> RIO env Text
forall a b. (a -> b) -> a -> b
$ NewPrettyException -> PrettyException
forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException (NewPrettyException -> PrettyException)
-> NewPrettyException -> PrettyException
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 PrettyException -> RIO env Text
forall e a. Exception e => e -> RIO env a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (PrettyException -> RIO env Text)
-> PrettyException -> RIO env Text
forall a b. (a -> b) -> a -> b
$ NewPrettyException -> PrettyException
forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException (NewPrettyException -> PrettyException)
-> NewPrettyException -> PrettyException
forall a b. (a -> b) -> a -> b
$
                TemplateName -> Path b File -> NewPrettyException
forall b. TemplateName -> Path b File -> NewPrettyException
LoadTemplateFailed TemplateName
name Path b File
path

    relSettings :: String -> Maybe TemplateDownloadSettings
    relSettings :: String -> Maybe TemplateDownloadSettings
relSettings String
req = do
        RepoTemplatePath
rtp <- RepoService -> Text -> Maybe RepoTemplatePath
parseRepoPathWithService RepoService
defaultRepoService (String -> Text
T.pack String
req)
        TemplateDownloadSettings -> Maybe TemplateDownloadSettings
forall a. a -> Maybe a
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 = 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
-> (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 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
                     -> (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 <- String -> RIO env Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
url
        let dReq :: DownloadRequest
dReq = Bool -> DownloadRequest -> DownloadRequest
setForceDownload Bool
True (DownloadRequest -> DownloadRequest)
-> DownloadRequest -> DownloadRequest
forall a b. (a -> b) -> a -> b
$
                       Request -> DownloadRequest
mkDownloadRequest (Request -> Request
setRequestCheckStatus Request
req)
        TemplateFrom -> RIO env ()
logIt TemplateFrom
RemoteTemp
        RIO env ()
-> (VerifiedDownloadException -> RIO env ()) -> RIO env ()
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch
          ( do let label :: Text
label = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
path
               Bool
res <- DownloadRequest
-> Path Abs File -> Text -> Maybe Int -> RIO env Bool
forall env.
HasTerm env =>
DownloadRequest
-> Path Abs File -> Text -> Maybe Int -> RIO env Bool
verifiedDownloadWithProgress DownloadRequest
dReq Path Abs File
path Text
label Maybe Int
forall a. Maybe a
Nothing
               if Bool
res
                 then Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) =>
Utf8Builder -> m ()
logStickyDone (Utf8Builder
"Downloaded " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
label Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
".")
                 else Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) =>
Utf8Builder -> m ()
logStickyDone Utf8Builder
"Already downloaded."
          )
          (String -> Path Abs File -> VerifiedDownloadException -> RIO env ()
useCachedVersionOrThrow String
url Path Abs File
path)
        Path Abs File -> (ByteString -> Either String Text) -> RIO env Text
forall b.
Path b File -> (ByteString -> Either String Text) -> RIO env Text
loadLocalFile Path Abs File
path ByteString -> Either String Text
extract

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

      if Bool
exists
        then StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn
                 ( String -> StyleDoc
flow String
"Tried to download the template but an error was \
                        \found. Using cached local version. It may not be the \
                        \most recent version though."
                 )
        else PrettyException -> RIO env ()
forall e a. Exception e => e -> RIO env a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (PrettyException -> RIO env ()) -> PrettyException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ NewPrettyException -> PrettyException
forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException (NewPrettyException -> PrettyException)
-> NewPrettyException -> 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 = (UnicodeException -> String)
-> Either UnicodeException Text -> Either String Text
forall a1 a2 b. (a1 -> a2) -> Either a1 b -> Either a2 b
mapLeft UnicodeException -> String
forall a. Show a => a -> String
show (Either UnicodeException Text -> Either String Text)
-> (ByteString -> Either UnicodeException Text)
-> ByteString
-> Either String Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Text
decodeUtf8'

asIsFromUrl :: String -> TemplateDownloadSettings
asIsFromUrl :: String -> TemplateDownloadSettings
asIsFromUrl String
url = TemplateDownloadSettings
  { tplDownloadUrl :: String
tplDownloadUrl = String
url
  , 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 = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [ String
"https://api.github.com/repos/"
          , Text -> String
T.unpack Text
user
          , String
"/stack-templates/contents/"
          , Text -> String
T.unpack Text
name
          ]
    , tplExtract :: ByteString -> Either String Text
tplExtract = \ByteString
bs -> do
        Value
decodedJson <- ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
eitherDecode (ByteString -> ByteString
LB.fromStrict ByteString
bs)
        case Value
decodedJson of
          Object Object
o | Just (String Text
content) <- Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
"content" Object
o -> do
                       let noNewlines :: Text -> Text
noNewlines = (Char -> Bool) -> Text -> Text
T.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n')
                       ByteString
bsContent <- ByteString -> Either String ByteString
B64.decode (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8 (Text -> Text
noNewlines Text
content)
                       (UnicodeException -> String)
-> Either UnicodeException Text -> Either String Text
forall a1 a2 b. (a1 -> a2) -> Either a1 b -> Either a2 b
mapLeft UnicodeException -> String
forall a. Show a => a -> String
show (Either UnicodeException Text -> Either String Text)
-> Either UnicodeException Text -> Either String Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
bsContent
          Value
_ ->
            String -> Either String Text
forall a b. a -> Either a b
Left String
"Couldn't parse GitHub response as a JSON object with a \"content\" field"
    }

settingsFromRepoTemplatePath (RepoTemplatePath RepoService
GitLab Text
user Text
name) =
    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) =
    String -> TemplateDownloadSettings
asIsFromUrl (String -> TemplateDownloadSettings)
-> String -> TemplateDownloadSettings
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"https://bitbucket.org"
        , String
"/"
        , Text -> String
T.unpack Text
user
        , String
"/stack-templates/raw/master/"
        , Text -> String
T.unpack Text
name
        ]

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

applyTemplate
    :: HasConfig env
    => PackageName
    -> TemplateName
    -> Map Text Text
    -> Path Abs Dir
    -> Text
    -> RIO env  (Map (Path Abs File) LB.ByteString)
applyTemplate :: forall env.
HasConfig env =>
PackageName
-> TemplateName
-> Map Text Text
-> Path Abs Dir
-> Text
-> RIO env (Map (Path Abs File) ByteString)
applyTemplate PackageName
project TemplateName
template Map Text Text
nonceParams Path Abs Dir
dir Text
templateText = do
    Config
config <- Getting Config env Config -> RIO env Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL
    Text
currentYear <- do
      UTCTime
now <- IO UTCTime -> RIO env UTCTime
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
      let (Year
year, Int
_, Int
_) = Day -> (Year, Int, Int)
toGregorian (UTCTime -> Day
utctDay UTCTime
now)
      Text -> RIO env Text
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> RIO env Text) -> Text -> RIO env Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> (Year -> String) -> Year -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Year -> String
forall a. Show a => a -> String
show (Year -> Text) -> Year -> Text
forall a b. (a -> b) -> a -> b
$ Year
year
    let context :: Map Text Text
context = [Map Text Text] -> Map Text Text
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
M.unions [Map Text Text
nonceParams, Map Text Text
nameParams, Map Text Text
configParams, Map Text Text
yearParam]
          where
            nameAsVarId :: Text
nameAsVarId = HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"-" Text
"_" (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
project
            nameAsModule :: Text
nameAsModule = (Char -> Bool) -> Text -> Text
T.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ') (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.toTitle (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"-" Text
" " (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$
                               String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
project
            nameParams :: Map Text Text
nameParams = [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ (Text
"name", String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
project)
                                    , (Text
"name-as-varid", Text
nameAsVarId)
                                    , (Text
"name-as-module", Text
nameAsModule) ]
            configParams :: Map Text Text
configParams = Config -> Map Text Text
configTemplateParams Config
config
            yearParam :: Map Text Text
yearParam = Text -> Text -> Map Text Text
forall k a. k -> a -> Map k a
M.singleton Text
"year" Text
currentYear
    Map String ByteString
files :: Map FilePath LB.ByteString <-
        RIO env (Map String ByteString)
-> (ProjectTemplateException -> RIO env (Map String ByteString))
-> RIO env (Map String ByteString)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch
            ( WriterT (Map String ByteString) (RIO env) ()
-> RIO env (Map String ByteString)
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT (WriterT (Map String ByteString) (RIO env) ()
 -> RIO env (Map String ByteString))
-> WriterT (Map String ByteString) (RIO env) ()
-> RIO env (Map String ByteString)
forall a b. (a -> b) -> a -> b
$ ConduitT () Void (WriterT (Map String ByteString) (RIO env)) ()
-> WriterT (Map String ByteString) (RIO env) ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void (WriterT (Map String ByteString) (RIO env)) ()
 -> WriterT (Map String ByteString) (RIO env) ())
-> ConduitT () Void (WriterT (Map String ByteString) (RIO env)) ()
-> WriterT (Map String ByteString) (RIO env) ()
forall a b. (a -> b) -> a -> b
$
                  ByteString
-> ConduitT
     () ByteString (WriterT (Map String ByteString) (RIO env)) ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Text -> ByteString
T.encodeUtf8 Text
templateText) ConduitT
  () ByteString (WriterT (Map String ByteString) (RIO env)) ()
-> ConduitT
     ByteString Void (WriterT (Map String ByteString) (RIO env)) ()
-> ConduitT () Void (WriterT (Map String ByteString) (RIO env)) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.|
                  (String
 -> ConduitT
      ByteString Void (WriterT (Map String ByteString) (RIO env)) ())
-> (Text -> Text)
-> ConduitT
     ByteString Void (WriterT (Map String ByteString) (RIO env)) ()
forall (m :: * -> *) o.
MonadThrow m =>
(String -> ConduitM ByteString o m ())
-> (Text -> Text) -> ConduitM ByteString o m ()
unpackTemplate String
-> ConduitT
     ByteString Void (WriterT (Map String ByteString) (RIO env)) ()
forall (m :: * -> *).
MonadWriter (Map String ByteString) m =>
FileReceiver m
receiveMem Text -> Text
forall a. a -> a
id
            )
            ( \(ProjectTemplateException
e :: ProjectTemplateException) ->
                  PrettyException -> RIO env (Map String ByteString)
forall e a. Exception e => e -> RIO env a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (PrettyException -> RIO env (Map String ByteString))
-> PrettyException -> RIO env (Map String ByteString)
forall a b. (a -> b) -> a -> b
$ NewPrettyException -> PrettyException
forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException (NewPrettyException -> PrettyException)
-> NewPrettyException -> PrettyException
forall a b. (a -> b) -> a -> b
$
                      TemplateName -> StyleDoc -> NewPrettyException
TemplateInvalid TemplateName
template (String -> StyleDoc
string (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ ProjectTemplateException -> String
forall e. Exception e => e -> String
displayException ProjectTemplateException
e)
            )
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Map String ByteString -> Bool
forall k a. Map k a -> Bool
M.null Map String ByteString
files) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
        PrettyException -> RIO env ()
forall e a. Exception e => e -> RIO env a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (PrettyException -> RIO env ()) -> PrettyException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ NewPrettyException -> PrettyException
forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException (NewPrettyException -> PrettyException)
-> NewPrettyException -> 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" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isSuffixOf` String
f Bool -> Bool -> Bool
|| String
f String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"package.yaml"
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any String -> Bool
isPkgSpec ([String] -> Bool)
-> (Map String ByteString -> [String])
-> Map String ByteString
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String ByteString -> [String]
forall k a. Map k a -> [k]
M.keys (Map String ByteString -> Bool) -> Map String ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ Map String ByteString
files) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
         PrettyException -> RIO env ()
forall e a. Exception e => e -> RIO env a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (PrettyException -> RIO env ()) -> PrettyException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ NewPrettyException -> PrettyException
forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException (NewPrettyException -> PrettyException)
-> NewPrettyException -> 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 Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
50000
          , Right Text
text <- ByteString -> Either UnicodeException Text
TLE.decodeUtf8' ByteString
bytes = do
              let etemplateCompiled :: Either ParseError Template
etemplateCompiled = String -> Text -> Either ParseError Template
Mustache.compileTemplate (Text -> String
T.unpack (TemplateName -> Text
templateName TemplateName
template)) (Text -> Either ParseError Template)
-> Text -> Either ParseError Template
forall a b. (a -> b) -> a -> b
$ Text -> Text
TL.toStrict Text
text
              Template
templateCompiled <- case Either ParseError Template
etemplateCompiled of
                Left ParseError
e -> PrettyException -> m Template
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (PrettyException -> m Template) -> PrettyException -> m Template
forall a b. (a -> b) -> a -> b
$ NewPrettyException -> PrettyException
forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException (NewPrettyException -> PrettyException)
-> NewPrettyException -> PrettyException
forall a b. (a -> b) -> a -> b
$
                    TemplateName -> StyleDoc -> NewPrettyException
TemplateInvalid
                        TemplateName
template
                        (    String -> StyleDoc
flow String
"Stack encountered the following error:"
                          StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
                             -- Text.Parsec.Error.ParseError is not an instance

                             -- of Control.Exception.

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

          -- Too large or too binary

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

        -- Accumulate any missing keys as the file is processed

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

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

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

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

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

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

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

checkForOverwrite :: (MonadIO m, MonadThrow m) => Text -> [Path Abs File] -> m ()
checkForOverwrite :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Text -> [Path Abs File] -> m ()
checkForOverwrite Text
name [Path Abs File]
files = do
    [Path Abs File]
overwrites <- (Path Abs File -> m Bool) -> [Path Abs File] -> m [Path Abs File]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM Path Abs File -> m Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist [Path Abs File]
files
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Path Abs File] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Path Abs File]
overwrites) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        PrettyException -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (PrettyException -> m ()) -> PrettyException -> m ()
forall a b. (a -> b) -> a -> b
$ NewPrettyException -> PrettyException
forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException (NewPrettyException -> PrettyException)
-> NewPrettyException -> 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 =
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
    [(Path Abs File, ByteString)]
-> ((Path Abs File, ByteString) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_
        (Map (Path Abs File) ByteString -> [(Path Abs File, ByteString)]
forall k a. Map k a -> [(k, a)]
M.toList Map (Path Abs File) ByteString
files)
        (\(Path Abs File
fp,ByteString
bytes) ->
              do Path Abs Dir -> IO ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
fp)
                 Path Abs File -> Builder -> IO ()
forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
fp (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
lazyByteString ByteString
bytes)

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

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

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