{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Stack.New
( NewOpts (..)
, TemplateName
, newCmd
, new
) where
import Control.Monad.Trans.Writer.Strict ( execWriterT )
import Data.Aeson as A
import qualified Data.Aeson.KeyMap as KeyMap
import qualified Data.ByteString.Base64 as B64
import Data.ByteString.Builder ( lazyByteString )
import qualified Data.ByteString.Lazy as LB
import Data.Conduit ( yield )
import qualified Data.List as L
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import Data.Time.Calendar ( toGregorian )
import Data.Time.Clock ( getCurrentTime, utctDay )
import Network.HTTP.Client ( applyBasicAuth )
import Network.HTTP.StackClient
( HttpException (..), HttpExceptionContent (..)
, Response (..), VerifiedDownloadException (..)
, mkDownloadRequest, notFound404, parseRequest
, setForceDownload, setRequestCheckStatus
, verifiedDownloadWithProgress
)
import Path ( (</>), dirname, parent, parseRelDir, parseRelFile )
import Path.IO
( doesDirExist, doesFileExist, ensureDir, getCurrentDir )
import RIO.Process ( proc, runProcess_, withWorkingDir )
import Stack.Constants
( altGitHubTokenEnvVar, backupUrlRelPath, gitHubBasicAuthType
, gitHubTokenEnvVar, stackDotYaml, wiredInPackages
)
import Stack.Constants.Config ( templatesDir )
import Stack.Init ( InitOpts (..), initProject )
import Stack.Prelude
import Stack.Runners
( ShouldReexec (..), withConfig, withGlobalProject )
import Stack.Types.Config ( Config (..), HasConfig (..) )
import Stack.Types.GlobalOpts ( GlobalOpts (..) )
import Stack.Types.Runner ( Runner, globalOptsL )
import Stack.Types.SCM ( SCM (..) )
import Stack.Types.TemplateName
( RepoService (..), RepoTemplatePath (..), TemplateName
, TemplatePath (..), defaultTemplateName
, parseRepoPathWithService, templateName, templatePath
)
import System.Environment ( lookupEnv )
import qualified Text.Mustache as Mustache
import qualified Text.Mustache.Render as Mustache
import Text.ProjectTemplate
( ProjectTemplateException, receiveMem, unpackTemplate )
data NewPrettyException
= ProjectDirAlreadyExists !String !(Path Abs Dir)
| DownloadTemplateFailed !Text !String !VerifiedDownloadException
| forall b. LoadTemplateFailed !TemplateName !(Path b File)
| forall b. !TemplateName !(Path b File) !String
| TemplateInvalid !TemplateName !StyleDoc
| MagicPackageNameInvalid !String
| AttemptedOverwrites !Text ![Path Abs File]
deriving Typeable
deriving instance Show NewPrettyException
instance Pretty NewPrettyException where
pretty :: NewPrettyException -> StyleDoc
pretty (ProjectDirAlreadyExists String
name Path Abs Dir
path) =
StyleDoc
"[S-2135]"
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"
, 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
<> String -> StyleDoc
string (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
<> String -> StyleDoc
string (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"
, 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"
, 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."
]
instance Exception NewPrettyException
data NewOpts = NewOpts
{ NewOpts -> PackageName
newOptsProjectName :: PackageName
, NewOpts -> Bool
newOptsCreateBare :: Bool
, NewOpts -> Maybe TemplateName
newOptsTemplate :: Maybe TemplateName
, NewOpts -> Map Text Text
newOptsNonceParams :: Map Text Text
}
newCmd :: (NewOpts, InitOpts) -> RIO Runner ()
newCmd :: (NewOpts, InitOpts) -> RIO Runner ()
newCmd (NewOpts
newOpts, InitOpts
initOpts) =
forall a. RIO Runner a -> RIO Runner a
withGlobalProject forall a b. (a -> b) -> a -> b
$ forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
YesReexec forall a b. (a -> b) -> a -> b
$ do
Path Abs Dir
dir <- forall env.
HasConfig env =>
NewOpts -> Bool -> RIO env (Path Abs Dir)
new NewOpts
newOpts (InitOpts -> Bool
forceOverwrite InitOpts
initOpts)
Bool
exists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist forall a b. (a -> b) -> a -> b
$ Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
stackDotYaml
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (InitOpts -> Bool
forceOverwrite InitOpts
initOpts Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
exists) forall a b. (a -> b) -> a -> b
$ do
GlobalOpts
go <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasRunner env => Lens' env GlobalOpts
globalOptsL
forall env.
(HasConfig env, HasGHCVariant env) =>
Path Abs Dir -> InitOpts -> Maybe AbstractResolver -> RIO env ()
initProject Path Abs Dir
dir InitOpts
initOpts (GlobalOpts -> Maybe AbstractResolver
globalResolver GlobalOpts
go)
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 e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM 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 (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir
pwd forall b t. Path b Dir -> Path Rel t -> Path b t
</> 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 e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM 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"
, 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
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
TemplateDownloadSettings
settings <- forall a. a -> Maybe a -> a
fromMaybe (forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM PrettyException
e) (String -> Maybe (RIO env TemplateDownloadSettings)
relSettings String
rawParam)
let url :: String
url = TemplateDownloadSettings -> String
tplDownloadUrl TemplateDownloadSettings
settings
mBasicAuth :: Maybe (ByteString, ByteString)
mBasicAuth = TemplateDownloadSettings -> Maybe (ByteString, ByteString)
tplBasicAuth TemplateDownloadSettings
settings
extract :: ByteString -> Either String Text
extract = TemplateDownloadSettings -> ByteString -> Either String Text
tplExtract TemplateDownloadSettings
settings
String
-> Maybe (ByteString, ByteString)
-> (ByteString -> Either String Text)
-> Path Abs File
-> RIO env Text
downloadTemplate String
url Maybe (ByteString, ByteString)
mBasicAuth ByteString -> Either String Text
extract (Path Abs Dir
templateDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFile)
)
RepoPath RepoTemplatePath
rtp -> do
TemplateDownloadSettings
settings <- forall env.
HasTerm env =>
RepoTemplatePath -> RIO env TemplateDownloadSettings
settingsFromRepoTemplatePath RepoTemplatePath
rtp
TemplateDownloadSettings -> Path Abs Dir -> RIO env Text
downloadFromUrl TemplateDownloadSettings
settings Path Abs Dir
templateDir
where
loadLocalFile :: Path b File
-> (ByteString -> Either String Text)
-> RIO env Text
loadLocalFile :: forall b.
Path b File -> (ByteString -> Either String Text) -> RIO env Text
loadLocalFile Path b File
path ByteString -> Either String Text
extract = do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$
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)
case ByteString -> Either String Text
extract ByteString
bs of
Left String
err -> forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM 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 e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM forall a b. (a -> b) -> a -> b
$ forall b. TemplateName -> Path b File -> NewPrettyException
LoadTemplateFailed TemplateName
name Path b File
path
relSettings :: String -> Maybe (RIO env TemplateDownloadSettings)
relSettings :: String -> Maybe (RIO env TemplateDownloadSettings)
relSettings String
req = do
RepoTemplatePath
rtp <- RepoService -> Text -> Maybe RepoTemplatePath
parseRepoPathWithService RepoService
defaultRepoService (String -> Text
T.pack String
req)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall env.
HasTerm env =>
RepoTemplatePath -> RIO env TemplateDownloadSettings
settingsFromRepoTemplatePath RepoTemplatePath
rtp)
downloadFromUrl :: TemplateDownloadSettings -> Path Abs Dir -> RIO env Text
downloadFromUrl :: TemplateDownloadSettings -> Path Abs Dir -> RIO env Text
downloadFromUrl TemplateDownloadSettings
settings Path Abs Dir
templateDir = do
let url :: String
url = TemplateDownloadSettings -> String
tplDownloadUrl TemplateDownloadSettings
settings
mBasicAuth :: Maybe (ByteString, ByteString)
mBasicAuth = TemplateDownloadSettings -> Maybe (ByteString, ByteString)
tplBasicAuth TemplateDownloadSettings
settings
rel :: Path Rel File
rel = forall a. a -> Maybe a -> a
fromMaybe Path Rel File
backupUrlRelPath (forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile String
url)
String
-> Maybe (ByteString, ByteString)
-> (ByteString -> Either String Text)
-> Path Abs File
-> RIO env Text
downloadTemplate String
url Maybe (ByteString, ByteString)
mBasicAuth (TemplateDownloadSettings -> ByteString -> Either String Text
tplExtract TemplateDownloadSettings
settings) (Path Abs Dir
templateDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
rel)
downloadTemplate ::
String
-> Maybe (ByteString, ByteString)
-> (ByteString -> Either String Text)
-> Path Abs File
-> RIO env Text
downloadTemplate :: String
-> Maybe (ByteString, ByteString)
-> (ByteString -> Either String Text)
-> Path Abs File
-> RIO env Text
downloadTemplate String
url Maybe (ByteString, ByteString)
mBasicAuth ByteString -> Either String Text
extract Path Abs File
path = do
Request
req <- forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
url
let authReq :: Request
authReq = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ByteString -> ByteString -> Request -> Request
applyBasicAuth) Maybe (ByteString, ByteString)
mBasicAuth Request
req
dReq :: DownloadRequest
dReq = Bool -> DownloadRequest -> DownloadRequest
setForceDownload Bool
True forall a b. (a -> b) -> a -> b
$
Request -> DownloadRequest
mkDownloadRequest (Request -> Request
setRequestCheckStatus Request
authReq)
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 e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM 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 -> Maybe (ByteString, ByteString)
tplBasicAuth :: Maybe (ByteString, ByteString)
, :: 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
, tplBasicAuth :: Maybe (ByteString, ByteString)
tplBasicAuth = forall a. Maybe a
Nothing
, tplExtract :: ByteString -> Either String Text
tplExtract = ByteString -> Either String Text
eitherByteStringToText
}
settingsFromRepoTemplatePath ::
HasTerm env
=> RepoTemplatePath
-> RIO env TemplateDownloadSettings
settingsFromRepoTemplatePath :: forall env.
HasTerm env =>
RepoTemplatePath -> RIO env TemplateDownloadSettings
settingsFromRepoTemplatePath (RepoTemplatePath RepoService
GitHub Text
user Text
name) = do
let basicAuthMsg :: String -> m ()
basicAuthMsg String
token = forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
[ String -> StyleDoc
flow String
"Using content of"
, forall a. IsString a => String -> a
fromString String
token
, String -> StyleDoc
flow String
" environment variable to authenticate GitHub REST API."
]
Maybe (ByteString, ByteString)
mBasicAuth <- do
String
wantGitHubToken <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe String
"" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
gitHubTokenEnvVar
if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null String
wantGitHubToken)
then do
forall {env} {m :: * -> *}.
(HasTerm env, MonadReader env m, MonadIO m) =>
String -> m ()
basicAuthMsg String
gitHubTokenEnvVar
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (ByteString
gitHubBasicAuthType, forall a. IsString a => String -> a
fromString String
wantGitHubToken)
else do
String
wantAltGitHubToken <-
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe String
"" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
altGitHubTokenEnvVar
if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null String
wantAltGitHubToken)
then do
forall {env} {m :: * -> *}.
(HasTerm env, MonadReader env m, MonadIO m) =>
String -> m ()
basicAuthMsg String
altGitHubTokenEnvVar
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (ByteString
gitHubBasicAuthType, forall a. IsString a => String -> a
fromString String
wantAltGitHubToken)
else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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
]
, tplBasicAuth :: Maybe (ByteString, ByteString)
tplBasicAuth = Maybe (ByteString, ByteString)
mBasicAuth
, 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) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
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) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
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
]
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 e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM 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 e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM 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 e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM 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.")
let applyMustache :: ByteString -> m (ByteString, Set String)
applyMustache ByteString
bytes
| 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 e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM 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
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)
| Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString
bytes, forall a. Set a
S.empty)
processFile :: Set String
-> (String, ByteString)
-> m (Set String, (Path Abs File, ByteString))
processFile Set String
mks (String
fpOrig, ByteString
bytes) = do
(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
$
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
<> 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
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 e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM forall a b. (a -> b) -> a -> b
$ Text -> [Path Abs File] -> NewPrettyException
AttemptedOverwrites Text
name [Path Abs File]
overwrites
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)
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..."
]
)
defaultRepoService :: RepoService
defaultRepoService :: RepoService
defaultRepoService = RepoService
GitHub