stack-2.11.1: src/Stack/New.hs
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Types and functions related to Stack's @new@ command.
module Stack.New
( NewOpts (..)
, TemplateName
, newCmd
, new
) where
import Control.Monad.Trans.Writer.Strict ( execWriterT )
import Data.Aeson as A
import qualified Data.Aeson.KeyMap as KeyMap
import qualified Data.ByteString.Base64 as B64
import Data.ByteString.Builder ( lazyByteString )
import qualified Data.ByteString.Lazy as LB
import Data.Conduit ( yield )
import qualified Data.List as L
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import Data.Time.Calendar ( toGregorian )
import Data.Time.Clock ( getCurrentTime, utctDay )
import Network.HTTP.Client ( applyBasicAuth )
import Network.HTTP.StackClient
( HttpException (..), HttpExceptionContent (..)
, Response (..), VerifiedDownloadException (..)
, mkDownloadRequest, notFound404, parseRequest
, setForceDownload, setRequestCheckStatus
, verifiedDownloadWithProgress
)
import Path ( (</>), dirname, parent, parseRelDir, parseRelFile )
import Path.IO
( doesDirExist, doesFileExist, ensureDir, getCurrentDir )
import RIO.Process ( proc, runProcess_, withWorkingDir )
import Stack.Constants
( altGitHubTokenEnvVar, backupUrlRelPath, gitHubBasicAuthType
, gitHubTokenEnvVar, stackDotYaml, wiredInPackages
)
import Stack.Constants.Config ( templatesDir )
import Stack.Init ( InitOpts (..), initProject )
import Stack.Prelude
import Stack.Runners
( ShouldReexec (..), withConfig, withGlobalProject )
import Stack.Types.Config ( Config (..), HasConfig (..) )
import Stack.Types.GlobalOpts ( GlobalOpts (..) )
import Stack.Types.Runner ( Runner, globalOptsL )
import Stack.Types.SCM ( SCM (..) )
import Stack.Types.TemplateName
( RepoService (..), RepoTemplatePath (..), TemplateName
, TemplatePath (..), defaultTemplateName
, parseRepoPathWithService, templateName, templatePath
)
import System.Environment ( lookupEnv )
import qualified Text.Mustache as Mustache
import qualified Text.Mustache.Render as Mustache
import Text.ProjectTemplate
( ProjectTemplateException, receiveMem, unpackTemplate )
--------------------------------------------------------------------------------
-- Exceptions
-- | Type representing \'pretty\' exceptions thrown by functions exported by the
-- "Stack.New" module.
data NewPrettyException
= ProjectDirAlreadyExists !String !(Path Abs Dir)
| DownloadTemplateFailed !Text !String !VerifiedDownloadException
| forall b. LoadTemplateFailed !TemplateName !(Path b File)
| forall b. ExtractTemplateFailed !TemplateName !(Path b File) !String
| TemplateInvalid !TemplateName !StyleDoc
| MagicPackageNameInvalid !String
| AttemptedOverwrites !Text ![Path Abs File]
deriving Typeable
deriving instance Show NewPrettyException
instance Pretty NewPrettyException where
pretty (ProjectDirAlreadyExists name path) =
"[S-2135]"
<> line
<> fillSep
[ flow "Stack failed to create a new directory for project"
, style Current (fromString name) <> ","
, flow "as the directory"
, pretty path
, flow "already exists."
]
pretty (DownloadTemplateFailed name url err) =
"[S-1688]"
<> line
<> fillSep
[ flow "Stack failed to download the template"
, style Current (fromString . T.unpack $ name)
, "from"
, style Url (fromString url) <> "."
]
<> blankLine
<> ( if isNotFound
then flow "Please check that the template exists at that \
\location."
<> blankLine
else mempty
)
<> fillSep
[ flow "While downloading, Stack encountered"
, msg
]
where
(msg, isNotFound) = case err of
DownloadHttpError (HttpExceptionRequest req content) ->
let msg' = flow "an HTTP error. Stack made the request:"
<> blankLine
<> string (show req)
<> blankLine
<> flow "and the content of the error was:"
<> blankLine
<> string (show content)
isNotFound404 = case content of
StatusCodeException res _ ->
responseStatus res == notFound404
_ -> False
in (msg', isNotFound404)
DownloadHttpError (InvalidUrlException url' reason) ->
let msg' = fillSep
[ flow "an HTTP error. The URL"
, style Url (fromString url')
, flow "was considered invalid because"
, fromString reason <> "."
]
in (msg', False)
_ -> let msg' = flow "the following error:"
<> blankLine
<> fromString (displayException err)
in (msg', False)
pretty (LoadTemplateFailed name path) =
"[S-3650]"
<> line
<> fillSep
[ flow "Stack failed to load the downloaded template"
, style Current (fromString $ T.unpack $ templateName name)
, "from"
, pretty path <> "."
]
pretty (ExtractTemplateFailed name path err) =
"[S-9582]"
<> line
<> fillSep
[ flow "Stack failed to extract the loaded template"
, style Current (fromString $ T.unpack $ templateName name)
, "at"
, pretty path <> "."
]
<> blankLine
<> flow "While extracting, Stack encountered the following error:"
<> blankLine
<> string err
pretty (TemplateInvalid name why) =
"[S-9490]"
<> line
<> fillSep
[ flow "Stack failed to use the template"
, style Current (fromString $ T.unpack $ templateName name) <> ","
, "as"
, why
]
pretty (MagicPackageNameInvalid name) =
"[S-5682]"
<> line
<> fillSep
[ flow "Stack declined to create a new directory for project"
, style Current (fromString name) <> ","
, flow "as package"
, fromString name
, flow "is 'wired-in' to a version of GHC. That can cause build \
\errors."
]
<> blankLine
<> fillSep
( flow "The names blocked by Stack are:"
: mkNarrativeList Nothing False
(map toStyleDoc (L.sort $ S.toList wiredInPackages))
)
where
toStyleDoc :: PackageName -> StyleDoc
toStyleDoc = fromString . packageNameString
pretty (AttemptedOverwrites name fps) =
"[S-3113]"
<> line
<> fillSep
[ flow "Stack declined to apply the template"
, style Current (fromString . T.unpack $ name) <> ","
, flow "as it would create files that already exist."
]
<> blankLine
<> flow "The template would create the following existing files:"
<> line
<> bulletedList (map (style File . pretty) fps)
<> blankLine
<> fillSep
[ "Use the"
, style Shell "--force"
, "flag to ignore this and overwrite those files."
]
instance Exception NewPrettyException
--------------------------------------------------------------------------------
-- Main project creation
-- | Type representing command line options for the @stack new@ command (other
-- than those applicable also to the @stack init@ command).
data NewOpts = NewOpts
{ newOptsProjectName :: PackageName
-- ^ Name of the project to create.
, newOptsCreateBare :: Bool
-- ^ Whether to create the project without a directory.
, newOptsTemplate :: Maybe TemplateName
-- ^ Name of the template to use.
, newOptsNonceParams :: Map Text Text
-- ^ Nonce parameters specified just for this invocation.
}
-- | Function underlying the @stack new@ command. Create a project directory
-- structure and initialize the Stack config.
newCmd :: (NewOpts, InitOpts) -> RIO Runner ()
newCmd (newOpts, initOpts) =
withGlobalProject $ withConfig YesReexec $ do
dir <- new newOpts (forceOverwrite initOpts)
exists <- doesFileExist $ dir </> stackDotYaml
when (forceOverwrite initOpts || not exists) $ do
go <- view globalOptsL
initProject dir initOpts (globalResolver go)
-- | Create a new project with the given options.
new :: HasConfig env => NewOpts -> Bool -> RIO env (Path Abs Dir)
new opts forceOverwrite = do
when (project `elem` wiredInPackages) $
prettyThrowM $ MagicPackageNameInvalid projectName
pwd <- getCurrentDir
absDir <- if bare
then pure pwd
else do relDir <- parseRelDir (packageNameString project)
pure (pwd </> relDir)
exists <- doesDirExist absDir
configTemplate <- view $ configL.to configDefaultTemplate
let template = fromMaybe defaultTemplateName $ asum [ cliOptionTemplate
, configTemplate
]
if exists && not bare
then prettyThrowM $ ProjectDirAlreadyExists projectName absDir
else do
templateText <- loadTemplate template (logUsing absDir template)
files <-
applyTemplate
project
template
(newOptsNonceParams opts)
absDir
templateText
when (not forceOverwrite && bare) $
checkForOverwrite (templateName template) (M.keys files)
writeTemplateFiles files
runTemplateInits absDir
pure absDir
where
cliOptionTemplate = newOptsTemplate opts
project = newOptsProjectName opts
projectName = packageNameString project
bare = newOptsCreateBare opts
logUsing absDir template templateFrom =
let loading = case templateFrom of
LocalTemp -> flow "Loading local"
RemoteTemp -> "Downloading"
in prettyInfo
( fillSep
[ loading
, "template"
, style
Current
(fromString $ T.unpack $ templateName template)
, flow "to create project"
, style Current (fromString projectName)
, "in"
, ( if bare
then flow "the current directory"
else fillSep
[ "directory"
, pretty $ dirname absDir
]
)
<> "..."
]
)
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 name logIt = do
templateDir <- view $ configL.to templatesDir
case templatePath name of
AbsPath absFile ->
logIt LocalTemp >> loadLocalFile absFile eitherByteStringToText
UrlPath s -> do
let settings = asIsFromUrl s
downloadFromUrl settings templateDir
RelPath rawParam relFile ->
catch
(do f <- loadLocalFile relFile eitherByteStringToText
logIt LocalTemp
pure f)
( \(e :: PrettyException) -> do
settings <- fromMaybe (throwM e) (relSettings rawParam)
let url = tplDownloadUrl settings
mBasicAuth = tplBasicAuth settings
extract = tplExtract settings
downloadTemplate url mBasicAuth extract (templateDir </> relFile)
)
RepoPath rtp -> do
settings <- settingsFromRepoTemplatePath rtp
downloadFromUrl settings templateDir
where
loadLocalFile :: Path b File
-> (ByteString -> Either String Text)
-> RIO env Text
loadLocalFile path extract = do
logDebug $
"Opening local template: \""
<> fromString (toFilePath path)
<> "\""
exists <- doesFileExist path
if exists
then do
bs <- readFileBinary (toFilePath path) --readFileUtf8 (toFilePath path)
case extract bs of
Left err -> prettyThrowM $ ExtractTemplateFailed name path err
Right template ->
pure template
else prettyThrowM $ LoadTemplateFailed name path
relSettings :: String -> Maybe (RIO env TemplateDownloadSettings)
relSettings req = do
rtp <- parseRepoPathWithService defaultRepoService (T.pack req)
pure (settingsFromRepoTemplatePath rtp)
downloadFromUrl :: TemplateDownloadSettings -> Path Abs Dir -> RIO env Text
downloadFromUrl settings templateDir = do
let url = tplDownloadUrl settings
mBasicAuth = tplBasicAuth settings
rel = fromMaybe backupUrlRelPath (parseRelFile url)
downloadTemplate url mBasicAuth (tplExtract settings) (templateDir </> rel)
downloadTemplate ::
String
-> Maybe (ByteString, ByteString)
-- ^ Optional HTTP \'Basic\' authentication (type, credentials)
-> (ByteString -> Either String Text)
-> Path Abs File
-> RIO env Text
downloadTemplate url mBasicAuth extract path = do
req <- parseRequest url
let authReq = maybe id (uncurry applyBasicAuth) mBasicAuth req
dReq = setForceDownload True $
mkDownloadRequest (setRequestCheckStatus authReq)
logIt RemoteTemp
catch
( do let label = T.pack $ toFilePath path
res <- verifiedDownloadWithProgress dReq path label Nothing
if res
then logStickyDone ("Downloaded " <> display label <> ".")
else logStickyDone "Already downloaded."
)
(useCachedVersionOrThrow url path)
loadLocalFile path extract
useCachedVersionOrThrow :: String
-> Path Abs File
-> VerifiedDownloadException
-> RIO env ()
useCachedVersionOrThrow url path exception = do
exists <- doesFileExist path
if exists
then
prettyWarn
( flow "Tried to download the template but an error was \
\found. Using cached local version. It may not be the \
\most recent version though."
)
else
prettyThrowM $ DownloadTemplateFailed (templateName name) url exception
-- | Type representing settings for the download of Stack project templates.
data TemplateDownloadSettings = TemplateDownloadSettings
{ tplDownloadUrl :: String
, tplBasicAuth :: Maybe (ByteString, ByteString)
-- ^ Optional HTTP 'Basic' authentication (type, credentials)
, tplExtract :: ByteString -> Either String Text
}
eitherByteStringToText :: ByteString -> Either String Text
eitherByteStringToText = mapLeft show . decodeUtf8'
asIsFromUrl :: String -> TemplateDownloadSettings
asIsFromUrl url = TemplateDownloadSettings
{ tplDownloadUrl = url
, tplBasicAuth = Nothing
, tplExtract = eitherByteStringToText
}
-- | Construct settings for downloading a Stack project template from a
-- repository.
settingsFromRepoTemplatePath ::
HasTerm env
=> RepoTemplatePath
-> RIO env TemplateDownloadSettings
settingsFromRepoTemplatePath (RepoTemplatePath GitHub user name) = do
let basicAuthMsg token = prettyInfoL
[ flow "Using content of"
, fromString token
, flow " environment variable to authenticate GitHub REST API."
]
mBasicAuth <- do
wantGitHubToken <- liftIO $ fromMaybe "" <$> lookupEnv gitHubTokenEnvVar
if not (L.null wantGitHubToken)
then do
basicAuthMsg gitHubTokenEnvVar
pure $ Just (gitHubBasicAuthType, fromString wantGitHubToken)
else do
wantAltGitHubToken <-
liftIO $ fromMaybe "" <$> lookupEnv altGitHubTokenEnvVar
if not (L.null wantAltGitHubToken)
then do
basicAuthMsg altGitHubTokenEnvVar
pure $ Just (gitHubBasicAuthType, fromString wantAltGitHubToken)
else pure Nothing
pure $ TemplateDownloadSettings
{ tplDownloadUrl = concat
[ "https://api.github.com/repos/"
, T.unpack user
, "/stack-templates/contents/"
, T.unpack name
]
, tplBasicAuth = mBasicAuth
, tplExtract = \bs -> do
decodedJson <- eitherDecode (LB.fromStrict bs)
case decodedJson of
Object o | Just (String content) <- KeyMap.lookup "content" o -> do
let noNewlines = T.filter (/= '\n')
bsContent <- B64.decode $ T.encodeUtf8 (noNewlines content)
mapLeft show $ decodeUtf8' bsContent
_ ->
Left "Couldn't parse GitHub response as a JSON object with a \
\\"content\" field"
}
settingsFromRepoTemplatePath (RepoTemplatePath GitLab user name) = pure $
asIsFromUrl $ concat
[ "https://gitlab.com"
, "/"
, T.unpack user
, "/stack-templates/raw/master/"
, T.unpack name
]
settingsFromRepoTemplatePath (RepoTemplatePath Bitbucket user name) = pure $
asIsFromUrl $ concat
[ "https://bitbucket.org"
, "/"
, T.unpack user
, "/stack-templates/raw/master/"
, T.unpack 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 project template nonceParams dir templateText = do
config <- view configL
currentYear <- do
now <- liftIO getCurrentTime
let (year, _, _) = toGregorian (utctDay now)
pure $ T.pack . show $ year
let context = M.unions [nonceParams, nameParams, configParams, yearParam]
where
nameAsVarId = T.replace "-" "_" $ T.pack $ packageNameString project
nameAsModule = T.filter (/= ' ') $ T.toTitle $ T.replace "-" " " $
T.pack $ packageNameString project
nameParams = M.fromList [ ("name", T.pack $ packageNameString project)
, ("name-as-varid", nameAsVarId)
, ("name-as-module", nameAsModule) ]
configParams = configTemplateParams config
yearParam = M.singleton "year" currentYear
files :: Map FilePath LB.ByteString <-
catch
( execWriterT $ runConduit $
yield (T.encodeUtf8 templateText) .|
unpackTemplate receiveMem id
)
( \(e :: ProjectTemplateException) ->
prettyThrowM $ TemplateInvalid template (string $ displayException e)
)
when (M.null files) $
prettyThrowM $ TemplateInvalid
template
(flow "the template does not contain any files.")
let isPkgSpec f = ".cabal" `L.isSuffixOf` f || f == "package.yaml"
unless (any isPkgSpec . M.keys $ files) $
prettyThrowM $ TemplateInvalid
template
(flow "the template does not contain a Cabal or package.yaml file.")
-- Apply Mustache templating to a single file within the project template.
let applyMustache 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.
| LB.length bytes < 50000
, Right text <- TLE.decodeUtf8' bytes = do
let etemplateCompiled =
Mustache.compileTemplate (T.unpack (templateName template)) $ TL.toStrict text
templateCompiled <- case etemplateCompiled of
Left e -> prettyThrowM $ TemplateInvalid
template
( flow "Stack encountered the following error:"
<> blankLine
-- Text.Parsec.Error.ParseError is not an instance
-- of Control.Exception.
<> string (show e)
)
Right t -> pure t
let (substitutionErrors, applied) =
Mustache.checkedSubstitute templateCompiled context
missingKeys =
S.fromList $ concatMap onlyMissingKeys substitutionErrors
pure (LB.fromStrict $ encodeUtf8 applied, missingKeys)
-- Too large or too binary
| otherwise = pure (bytes, S.empty)
-- Accumulate any missing keys as the file is processed
processFile mks (fpOrig, bytes) = do
-- Apply the mustache template to the filenames as well, so that we
-- can have file names depend on the project name.
(fp, mks1) <- applyMustache $ TLE.encodeUtf8 $ TL.pack fpOrig
path <- parseRelFile $ TL.unpack $ TLE.decodeUtf8 fp
(bytes', mks2) <- applyMustache bytes
pure (mks <> mks1 <> mks2, (dir </> path, bytes'))
(missingKeys, results) <- mapAccumLM processFile S.empty (M.toList files)
unless (S.null missingKeys) $
prettyNote $
missingParameters
missingKeys
(configUserConfigPath config)
pure $ M.fromList results
where
onlyMissingKeys (Mustache.VariableNotFound ks) = map T.unpack ks
onlyMissingKeys _ = []
mapAccumLM :: Monad m => (a -> b -> m(a, c)) -> a -> [b] -> m(a, [c])
mapAccumLM _ a [] = pure (a, [])
mapAccumLM f a (x:xs) = do
(a', c) <- f a x
(a'', cs) <- mapAccumLM f a' xs
pure (a'', c:cs)
missingParameters :: Set String -> Path Abs File -> StyleDoc
missingParameters missingKeys userConfigPath =
fillSep
( flow "The following parameters were needed by the template but \
\not provided:"
: mkNarrativeList Nothing False
(map toStyleDoc (S.toList missingKeys))
)
<> blankLine
<> fillSep
[ flow "You can provide them in Stack's global YAML configuration \
\file"
, "(" <> pretty userConfigPath <> ")"
, "like this:"
]
<> blankLine
<> "templates:"
<> line
<> " params:"
<> line
<> vsep
( map
(\key -> " " <> fromString key <> ": value")
(S.toList missingKeys)
)
<> blankLine
<> flow "Or you can pass each one on the command line as parameters \
\like this:"
<> blankLine
<> style Shell
( fillSep
[ flow "stack new"
, fromString (packageNameString project)
, fromString $ T.unpack (templateName template)
, hsep $
map
( \key ->
fillSep [ "-p"
, "\"" <> fromString key <> ":value\""
]
)
(S.toList missingKeys)
]
)
<> line
where
toStyleDoc :: String -> StyleDoc
toStyleDoc = fromString
-- | Check if we're going to overwrite any existing files.
checkForOverwrite ::
(MonadIO m, MonadThrow m)
=> Text
-> [Path Abs File]
-> m ()
checkForOverwrite name files = do
overwrites <- filterM doesFileExist files
unless (null overwrites) $
prettyThrowM $ AttemptedOverwrites name overwrites
-- | Write files to the new project directory.
writeTemplateFiles ::
MonadIO m
=> Map (Path Abs File) LB.ByteString
-> m ()
writeTemplateFiles files =
liftIO $
forM_
(M.toList files)
(\(fp,bytes) ->
do ensureDir (parent fp)
writeBinaryFileAtomic fp $ lazyByteString bytes)
-- | Run any initialization functions, such as Git.
runTemplateInits :: HasConfig env => Path Abs Dir -> RIO env ()
runTemplateInits dir = do
config <- view configL
case configScmInit config of
Nothing -> pure ()
Just Git -> withWorkingDir (toFilePath dir) $
catchAny
(proc "git" ["init"] runProcess_)
( \_ -> prettyWarn $
fillSep
[ flow "Stack failed to run a"
, style Shell (flow "git init")
, flow "command. Ignoring..."
]
)
--------------------------------------------------------------------------------
-- Defaults
-- | The default service to use to download templates.
defaultRepoService :: RepoService
defaultRepoService = GitHub