stack-2.9.3: src/Stack/New.hs
{-# 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 (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"
, style Dir (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
<> fromString (show req)
<> blankLine
<> flow "and the content of the error was:"
<> blankLine
<> fromString (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"
, style File (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"
, style File (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."
]
pretty (DownloadTemplatesHelpFailed err) =
"[S-8143]"
<> line
<> fillSep
[ flow "Stack failed to download the help for"
, style Shell "stack templates" <> "."
]
<> blankLine
<> flow "While downloading, Stack encountered the following error:"
<> blankLine
<> string (displayException err)
pretty (TemplatesHelpEncodingInvalid url err) =
"[S-6670]"
<> line
<> fillSep
[ flow "Stack failed to decode the help for"
, style Shell "stack templates"
, flow "downloaded from"
, style Url (fromString url) <> "."
]
<> blankLine
<> flow "While decoding, Stack encountered the following error:"
<> blankLine
<> string (displayException err)
instance Exception NewPrettyException
--------------------------------------------------------------------------------
-- Main project creation
-- | Options for creating a new project.
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.
}
-- | 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) $
throwM $ PrettyException $ MagicPackageNameInvalid projectName
pwd <- getCurrentDir
absDir <- if bare then pure pwd
else do relDir <- parseRelDir (packageNameString project)
liftM (pwd </>) (pure relDir)
exists <- doesDirExist absDir
configTemplate <- view $ configL.to configDefaultTemplate
let template = fromMaybe defaultTemplateName $ asum [ cliOptionTemplate
, configTemplate
]
if exists && not bare
then throwM $ PrettyException $
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"
, style Dir (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
case relSettings rawParam of
Just settings -> do
let url = tplDownloadUrl settings
extract = tplExtract settings
downloadTemplate url extract (templateDir </> relFile)
Nothing -> throwM e
)
RepoPath rtp -> do
let 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 -> throwM $ PrettyException $
ExtractTemplateFailed name path err
Right template ->
pure template
else throwM $ PrettyException $
LoadTemplateFailed name path
relSettings :: String -> Maybe 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
rel = fromMaybe backupUrlRelPath (parseRelFile url)
downloadTemplate url (tplExtract settings) (templateDir </> rel)
downloadTemplate :: String
-> (ByteString
-> Either String Text)
-> Path Abs File
-> RIO env Text
downloadTemplate url extract path = do
req <- parseRequest url
let dReq = setForceDownload True $
mkDownloadRequest (setRequestCheckStatus req)
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 throwM $ PrettyException $
DownloadTemplateFailed (templateName name) url exception
data TemplateDownloadSettings = TemplateDownloadSettings
{ tplDownloadUrl :: String
, tplExtract :: ByteString -> Either String Text
}
eitherByteStringToText :: ByteString -> Either String Text
eitherByteStringToText = mapLeft show . decodeUtf8'
asIsFromUrl :: String -> TemplateDownloadSettings
asIsFromUrl url = TemplateDownloadSettings
{ tplDownloadUrl = url
, tplExtract = eitherByteStringToText
}
-- | Construct a URL for downloading from a repo.
settingsFromRepoTemplatePath :: RepoTemplatePath -> TemplateDownloadSettings
settingsFromRepoTemplatePath (RepoTemplatePath GitHub user name) =
-- T.concat ["https://raw.githubusercontent.com", "/", user, "/stack-templates/master/", name]
TemplateDownloadSettings
{ tplDownloadUrl = concat
[ "https://api.github.com/repos/"
, T.unpack user
, "/stack-templates/contents/"
, T.unpack name
]
, 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) =
asIsFromUrl $ concat
[ "https://gitlab.com"
, "/"
, T.unpack user
, "/stack-templates/raw/master/"
, T.unpack name
]
settingsFromRepoTemplatePath (RepoTemplatePath Bitbucket user name) =
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) ->
throwM $ PrettyException $
TemplateInvalid template (string $ displayException e)
)
when (M.null files) $
throwM $ PrettyException $
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) $
throwM $ PrettyException $
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 -> throwM $ PrettyException $
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) $ do
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"
, "(" <> style 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) $
throwM $ PrettyException $ 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..."
]
)
-- | Display help for the templates command.
templatesHelp :: HasLogFunc env => RIO env ()
templatesHelp = do
let url = defaultTemplatesHelpUrl
req <- liftM setGitHubHeaders (parseUrlThrow url)
resp <- catch
(httpLbs req)
(throwM . PrettyException. DownloadTemplatesHelpFailed)
case decodeUtf8' $ LB.toStrict $ getResponseBody resp of
Left err -> throwM $ PrettyException $ TemplatesHelpEncodingInvalid url err
Right txt -> logInfo $ display txt
--------------------------------------------------------------------------------
-- Defaults
-- | The default service to use to download templates.
defaultRepoService :: RepoService
defaultRepoService = GitHub
-- | Default web URL to get the `stack templates` help output.
defaultTemplatesHelpUrl :: String
defaultTemplatesHelpUrl =
"https://raw.githubusercontent.com/commercialhaskell/stack-templates/master/STACK_HELP.md"