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

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

-- project.


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

import           Stack.Prelude
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           Data.List
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy.Encoding as TLE
import           Data.Time.Calendar
import           Data.Time.Clock
import           Network.HTTP.StackClient (VerifiedDownloadException (..), Request, HttpException,
                                           getResponseBody, httpLbs, mkDownloadRequest, parseRequest, parseUrlThrow,
                                           setForceDownload, setGitHubHeaders, setRequestCheckStatus, verifiedDownloadWithProgress)
import           Path
import           Path.IO
import           Stack.Constants
import           Stack.Constants.Config
import           Stack.Types.Config
import           Stack.Types.TemplateName
import           RIO.Process
import qualified Text.Mustache as Mustache
import qualified Text.Mustache.Render as Mustache
import           Text.ProjectTemplate

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

-- Main project creation


-- | Options for creating a new project.

data NewOpts = NewOpts
    { NewOpts -> PackageName
newOptsProjectName  :: PackageName
    -- ^ Name of the project to create.

    , NewOpts -> Bool
newOptsCreateBare   :: Bool
    -- ^ Whether to create the project without a directory.

    , NewOpts -> Maybe TemplateName
newOptsTemplate     :: Maybe TemplateName
    -- ^ Name of the template to use.

    , NewOpts -> Map Text Text
newOptsNonceParams  :: Map Text Text
    -- ^ Nonce parameters specified just for this invocation.

    }

-- | Create a new project with the given options.

new :: HasConfig env => NewOpts -> Bool -> RIO env (Path Abs Dir)
new :: forall env.
HasConfig env =>
NewOpts -> Bool -> RIO env (Path Abs Dir)
new NewOpts
opts Bool
forceOverwrite = do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NewOpts -> PackageName
newOptsProjectName NewOpts
opts forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Set PackageName
wiredInPackages) forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ PackageName -> NewException
Can'tUseWiredInName (NewOpts -> PackageName
newOptsProjectName NewOpts
opts)
    Path Abs Dir
pwd <- forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
    Path Abs Dir
absDir <- if Bool
bare then forall (m :: * -> *) a. Monad m => a -> m a
return Path Abs Dir
pwd
                      else do Path Rel Dir
relDir <- forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel Dir)
parseRelDir (PackageName -> [Char]
packageNameString PackageName
project)
                              forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Path Abs Dir
pwd forall b t. Path b Dir -> Path Rel t -> Path b t
</>) (forall (m :: * -> *) a. Monad m => a -> m a
return Path Rel Dir
relDir)
    Bool
exists <- forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist Path Abs Dir
absDir
    Maybe TemplateName
configTemplate <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Config -> Maybe TemplateName
configDefaultTemplate
    let template :: TemplateName
template = forall a. a -> Maybe a -> a
fromMaybe TemplateName
defaultTemplateName forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [ Maybe TemplateName
cliOptionTemplate
                                                        , Maybe TemplateName
configTemplate
                                                        ]
    if Bool
exists Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
bare
        then forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Path Abs Dir -> NewException
AlreadyExists Path Abs Dir
absDir)
        else do
            Text
templateText <- forall env.
HasConfig env =>
TemplateName -> (TemplateFrom -> RIO env ()) -> RIO env Text
loadTemplate TemplateName
template (forall {m :: * -> *} {env} {b}.
(MonadIO m, MonadReader env m, HasLogFunc env) =>
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) =>
[Path Abs File] -> m ()
checkForOverwrite (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 (m :: * -> *) a. Monad m => a -> m a
return Path Abs Dir
absDir
  where
    cliOptionTemplate :: Maybe TemplateName
cliOptionTemplate = NewOpts -> Maybe TemplateName
newOptsTemplate NewOpts
opts
    project :: PackageName
project = NewOpts -> PackageName
newOptsProjectName NewOpts
opts
    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 :: Utf8Builder
loading = case TemplateFrom
templateFrom of
                          TemplateFrom
LocalTemp -> Utf8Builder
"Loading local"
                          TemplateFrom
RemoteTemp -> Utf8Builder
"Downloading"
         in
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo
            (Utf8Builder
loading forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" template \"" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (TemplateName -> Text
templateName TemplateName
template) forall a. Semigroup a => a -> a -> a
<>
             Utf8Builder
"\" to create project \"" forall a. Semigroup a => a -> a -> a
<>
             forall a. IsString a => [Char] -> a
fromString (PackageName -> [Char]
packageNameString PackageName
project) forall a. Semigroup a => a -> a -> a
<>
             Utf8Builder
"\" in " forall a. Semigroup a => a -> a -> a
<>
             if Bool
bare then Utf8Builder
"the current directory"
                     else forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath (forall b. Path b Dir -> Path Rel Dir
dirname Path b Dir
absDir)) forall a. Semigroup a => a -> a -> a
<>
             Utf8Builder
" ...")

data TemplateFrom = LocalTemp | RemoteTemp

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

loadTemplate
    :: forall env. HasConfig env
    => TemplateName
    -> (TemplateFrom -> RIO env ())
    -> RIO env Text
loadTemplate :: forall env.
HasConfig env =>
TemplateName -> (TemplateFrom -> RIO env ()) -> RIO env Text
loadTemplate TemplateName
name TemplateFrom -> RIO env ()
logIt = do
    Path Abs Dir
templateDir <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Config -> Path Abs Dir
templatesDir
    case TemplateName -> TemplatePath
templatePath TemplateName
name of
        AbsPath Path Abs File
absFile -> TemplateFrom -> RIO env ()
logIt TemplateFrom
LocalTemp forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall b.
Path b File -> (ByteString -> Either [Char] Text) -> RIO env Text
loadLocalFile Path Abs File
absFile ByteString -> Either [Char] Text
eitherByteStringToText
        UrlPath [Char]
s -> do
            let settings :: TemplateDownloadSettings
settings = [Char] -> TemplateDownloadSettings
asIsFromUrl [Char]
s
            TemplateDownloadSettings -> Path Abs Dir -> RIO env Text
downloadFromUrl TemplateDownloadSettings
settings Path Abs Dir
templateDir
        RelPath [Char]
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 [Char] Text) -> RIO env Text
loadLocalFile Path Rel File
relFile ByteString -> Either [Char] Text
eitherByteStringToText
                    TemplateFrom -> RIO env ()
logIt TemplateFrom
LocalTemp
                    forall (m :: * -> *) a. Monad m => a -> m a
return Text
f)
                (\(NewException
e :: NewException) -> do
                      case [Char] -> Maybe TemplateDownloadSettings
relSettings [Char]
rawParam of
                        Just TemplateDownloadSettings
settings -> do
                          Request
req <- forall (m :: * -> *). MonadThrow m => [Char] -> m Request
parseRequest (TemplateDownloadSettings -> [Char]
tplDownloadUrl TemplateDownloadSettings
settings)
                          let extract :: ByteString -> Either [Char] Text
extract = TemplateDownloadSettings -> ByteString -> Either [Char] Text
tplExtract TemplateDownloadSettings
settings
                          Request
-> (ByteString -> Either [Char] Text)
-> Path Abs File
-> RIO env Text
downloadTemplate Request
req ByteString -> Either [Char] Text
extract (Path Abs Dir
templateDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFile)
                        Maybe TemplateDownloadSettings
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM NewException
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 [Char] Text) -> RIO env Text
loadLocalFile Path b File
path ByteString -> Either [Char] Text
extract = do
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Opening local template: \"" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
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 => [Char] -> m ByteString
readFileBinary (forall b t. Path b t -> [Char]
toFilePath Path b File
path) --readFileUtf8 (toFilePath path)

                case ByteString -> Either [Char] Text
extract ByteString
bs of
                    Left [Char]
err -> do
                        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Template extraction error: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display ([Char] -> Text
T.pack [Char]
err)
                        forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (TemplateName -> [Char] -> NewException
FailedToLoadTemplate TemplateName
name (forall b t. Path b t -> [Char]
toFilePath Path b File
path))
                    Right Text
template ->
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
template
            else forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (TemplateName -> [Char] -> NewException
FailedToLoadTemplate TemplateName
name (forall b t. Path b t -> [Char]
toFilePath Path b File
path))
    relSettings :: String -> Maybe TemplateDownloadSettings
    relSettings :: [Char] -> Maybe TemplateDownloadSettings
relSettings [Char]
req = do
        RepoTemplatePath
rtp <- RepoService -> Text -> Maybe RepoTemplatePath
parseRepoPathWithService RepoService
defaultRepoService ([Char] -> Text
T.pack [Char]
req)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (RepoTemplatePath -> TemplateDownloadSettings
settingsFromRepoTemplatePath RepoTemplatePath
rtp)
    downloadFromUrl :: TemplateDownloadSettings -> Path Abs Dir -> RIO env Text
    downloadFromUrl :: TemplateDownloadSettings -> Path Abs Dir -> RIO env Text
downloadFromUrl TemplateDownloadSettings
settings Path Abs Dir
templateDir = do
        let url :: [Char]
url = TemplateDownloadSettings -> [Char]
tplDownloadUrl TemplateDownloadSettings
settings
        Request
req <- forall (m :: * -> *). MonadThrow m => [Char] -> m Request
parseRequest [Char]
url
        let rel :: Path Rel File
rel = forall a. a -> Maybe a -> a
fromMaybe Path Rel File
backupUrlRelPath (forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
parseRelFile [Char]
url)
        Request
-> (ByteString -> Either [Char] Text)
-> Path Abs File
-> RIO env Text
downloadTemplate Request
req (TemplateDownloadSettings -> ByteString -> Either [Char] 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 :: Request -> (ByteString -> Either String Text) -> Path Abs File -> RIO env Text
    downloadTemplate :: Request
-> (ByteString -> Either [Char] Text)
-> Path Abs File
-> RIO env Text
downloadTemplate Request
req ByteString -> Either [Char] Text
extract Path Abs File
path = do
        let dReq :: DownloadRequest
dReq = Bool -> DownloadRequest -> DownloadRequest
setForceDownload Bool
True forall a b. (a -> b) -> a -> b
$ Request -> DownloadRequest
mkDownloadRequest (Request -> Request
setRequestCheckStatus Request
req)
        TemplateFrom -> RIO env ()
logIt TemplateFrom
RemoteTemp
        forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch
          (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ do
            forall env.
HasTerm env =>
DownloadRequest
-> Path Abs File -> Text -> Maybe Int -> RIO env Bool
verifiedDownloadWithProgress DownloadRequest
dReq Path Abs File
path ([Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> [Char]
toFilePath Path Abs File
path) forall a. Maybe a
Nothing
          )
          (Path Abs File -> VerifiedDownloadException -> RIO env ()
useCachedVersionOrThrow Path Abs File
path)

        forall b.
Path b File -> (ByteString -> Either [Char] Text) -> RIO env Text
loadLocalFile Path Abs File
path ByteString -> Either [Char] Text
extract
    useCachedVersionOrThrow :: Path Abs File -> VerifiedDownloadException -> RIO env ()
    useCachedVersionOrThrow :: Path Abs File -> VerifiedDownloadException -> RIO env ()
useCachedVersionOrThrow 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 do forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Tried to download the template but an error was found."
                forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Using cached local version. It may not be the most recent version though."
        else forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (TemplateName -> VerifiedDownloadException -> NewException
FailedToDownloadTemplate TemplateName
name VerifiedDownloadException
exception)

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

eitherByteStringToText :: ByteString -> Either String Text
eitherByteStringToText :: ByteString -> Either [Char] Text
eitherByteStringToText = forall a1 a2 b. (a1 -> a2) -> Either a1 b -> Either a2 b
mapLeft forall a. Show a => a -> [Char]
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Text
decodeUtf8'

asIsFromUrl :: String -> TemplateDownloadSettings
asIsFromUrl :: [Char] -> TemplateDownloadSettings
asIsFromUrl [Char]
url = TemplateDownloadSettings
  { tplDownloadUrl :: [Char]
tplDownloadUrl = [Char]
url
  , tplExtract :: ByteString -> Either [Char] Text
tplExtract = ByteString -> Either [Char] 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 :: [Char]
tplDownloadUrl = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]
"https://api.github.com/repos/", Text -> [Char]
T.unpack Text
user, [Char]
"/stack-templates/contents/", Text -> [Char]
T.unpack Text
name]
    , tplExtract :: ByteString -> Either [Char] Text
tplExtract = \ByteString
bs -> do
        Value
decodedJson <- forall a. FromJSON a => ByteString -> Either [Char] 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 [Char] 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 -> [Char]
show forall a b. (a -> b) -> a -> b
$ ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
bsContent
          Value
_ ->
            forall a b. a -> Either a b
Left [Char]
"Couldn't parse GitHub response as a JSON object with a \"content\" field"
    }

settingsFromRepoTemplatePath (RepoTemplatePath RepoService
GitLab Text
user Text
name) =
    [Char] -> TemplateDownloadSettings
asIsFromUrl forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]
"https://gitlab.com",                [Char]
"/", Text -> [Char]
T.unpack Text
user, [Char]
"/stack-templates/raw/master/", Text -> [Char]
T.unpack Text
name]
settingsFromRepoTemplatePath (RepoTemplatePath RepoService
Bitbucket Text
user Text
name) =
    [Char] -> TemplateDownloadSettings
asIsFromUrl forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]
"https://bitbucket.org",             [Char]
"/", Text -> [Char]
T.unpack Text
user, [Char]
"/stack-templates/raw/master/", Text -> [Char]
T.unpack Text
name]

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

applyTemplate
    :: HasConfig env
    => PackageName
    -> TemplateName
    -> Map Text Text
    -> Path Abs Dir
    -> Text
    -> RIO env  (Map (Path Abs File) LB.ByteString)
applyTemplate :: forall env.
HasConfig env =>
PackageName
-> TemplateName
-> Map Text Text
-> Path Abs Dir
-> Text
-> RIO env (Map (Path Abs File) ByteString)
applyTemplate PackageName
project TemplateName
template Map Text Text
nonceParams Path Abs Dir
dir Text
templateText = do
    Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
    Text
currentYear <- do
      UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
      let (Year
year, Int
_, Int
_) = Day -> (Year, Int, Int)
toGregorian (UTCTime -> Day
utctDay UTCTime
now)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
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
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
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
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString PackageName
project
            nameParams :: Map Text Text
nameParams = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ (Text
"name", [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
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 [Char] 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 =>
([Char] -> ConduitM ByteString o m ())
-> (Text -> Text) -> ConduitM ByteString o m ()
unpackTemplate forall (m :: * -> *).
MonadWriter (Map [Char] ByteString) m =>
FileReceiver m
receiveMem forall a. a -> a
id
              )
              (\(ProjectTemplateException
e :: ProjectTemplateException) ->
                   forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (TemplateName -> [Char] -> NewException
InvalidTemplate TemplateName
template (forall a. Show a => a -> [Char]
show ProjectTemplateException
e)))
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall k a. Map k a -> Bool
M.null Map [Char] ByteString
files) forall a b. (a -> b) -> a -> b
$
         forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (TemplateName -> [Char] -> NewException
InvalidTemplate TemplateName
template [Char]
"Template does not contain any files")

    let isPkgSpec :: [Char] -> Bool
isPkgSpec [Char]
f = [Char]
".cabal" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
f Bool -> Bool -> Bool
|| [Char]
f forall a. Eq a => a -> a -> Bool
== [Char]
"package.yaml"
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any [Char] -> 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 [Char] ByteString
files) forall a b. (a -> b) -> a -> b
$
         forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (TemplateName -> [Char] -> NewException
InvalidTemplate TemplateName
template
           [Char]
"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 [Char])
applyMustache ByteString
bytes
          -- Workaround for performance problems with mustache and

          -- large files, applies to Yesod templates with large

          -- bootstrap CSS files. See

          -- https://github.com/commercialhaskell/stack/issues/4133.

          | ByteString -> Int64
LB.length ByteString
bytes forall a. Ord a => a -> a -> Bool
< Int64
50000
          , Right Text
text <- ByteString -> Either UnicodeException Text
TLE.decodeUtf8' ByteString
bytes = do
              let etemplateCompiled :: Either ParseError Template
etemplateCompiled = [Char] -> Text -> Either ParseError Template
Mustache.compileTemplate (Text -> [Char]
T.unpack (TemplateName -> Text
templateName TemplateName
template)) forall a b. (a -> b) -> a -> b
$ Text -> Text
TL.toStrict Text
text
              Template
templateCompiled <- case Either ParseError Template
etemplateCompiled of
                Left ParseError
e -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ TemplateName -> [Char] -> NewException
InvalidTemplate TemplateName
template (forall a. Show a => a -> [Char]
show ParseError
e)
                Right Template
t -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 [Char]
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 -> [[Char]]
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 [Char]
missingKeys)

          -- Too large or too binary

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

        -- Accumulate any missing keys as the file is processed

        processFile :: Set [Char]
-> ([Char], ByteString)
-> m (Set [Char], (Path Abs File, ByteString))
processFile Set [Char]
mks ([Char]
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 [Char]
mks1) <- forall {m :: * -> *}.
MonadThrow m =>
ByteString -> m (ByteString, Set [Char])
applyMustache forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TLE.encodeUtf8 forall a b. (a -> b) -> a -> b
$ [Char] -> Text
TL.pack [Char]
fpOrig
          Path Rel File
path <- forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
parseRelFile forall a b. (a -> b) -> a -> b
$ Text -> [Char]
TL.unpack forall a b. (a -> b) -> a -> b
$ ByteString -> Text
TLE.decodeUtf8 ByteString
fp
          (ByteString
bytes', Set [Char]
mks2) <- forall {m :: * -> *}.
MonadThrow m =>
ByteString -> m (ByteString, Set [Char])
applyMustache ByteString
bytes
          forall (m :: * -> *) a. Monad m => a -> m a
return (Set [Char]
mks forall a. Semigroup a => a -> a -> a
<> Set [Char]
mks1 forall a. Semigroup a => a -> a -> a
<> Set [Char]
mks2, (Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
path, ByteString
bytes'))

    (Set [Char]
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 [Char]
-> ([Char], ByteString)
-> m (Set [Char], (Path Abs File, ByteString))
processFile forall a. Set a
S.empty (forall k a. Map k a -> [(k, a)]
M.toList Map [Char] ByteString
files)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Set a -> Bool
S.null Set [Char]
missingKeys) forall a b. (a -> b) -> a -> b
$ do
      let missingParameters :: NewException
missingParameters = PackageName
-> TemplateName -> Set [Char] -> Path Abs File -> NewException
MissingParameters
                               PackageName
project
                               TemplateName
template
                               Set [Char]
missingKeys
                               (Config -> Path Abs File
configUserConfigPath Config
config)
      forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder
"\n" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow NewException
missingParameters forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\n")
    forall (m :: * -> *) a. Monad m => a -> m a
return 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 -> [[Char]]
onlyMissingKeys (Mustache.VariableNotFound [Text]
ks) = forall a b. (a -> b) -> [a] -> [b]
map Text -> [Char]
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 (m :: * -> *) a. Monad m => a -> m a
return (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 (m :: * -> *) a. Monad m => a -> m a
return (a
a'', c
cforall a. a -> [a] -> [a]
:[c]
cs)

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

checkForOverwrite :: (MonadIO m, MonadThrow m) => [Path Abs File] -> m ()
checkForOverwrite :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
[Path Abs File] -> m ()
checkForOverwrite [Path Abs File]
files = do
    [Path Abs File]
overwrites <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist [Path Abs File]
files
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Path Abs File]
overwrites) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ([Path Abs File] -> NewException
AttemptedOverwrites [Path Abs File]
overwrites)

-- | Write files to the new project directory.

writeTemplateFiles
    :: MonadIO m
    => Map (Path Abs File) LB.ByteString -> m ()
writeTemplateFiles :: forall (m :: * -> *).
MonadIO m =>
Map (Path Abs File) ByteString -> m ()
writeTemplateFiles Map (Path Abs File) ByteString
files =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_
        (forall k a. Map k a -> [(k, a)]
M.toList Map (Path Abs File) ByteString
files)
        (\(Path Abs File
fp,ByteString
bytes) ->
              do forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (forall b t. Path b t -> Path b Dir
parent Path Abs File
fp)
                 forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
fp forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
lazyByteString ByteString
bytes)

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

runTemplateInits
    :: HasConfig env
    => Path Abs Dir
    -> RIO env ()
runTemplateInits :: forall env. HasConfig env => Path Abs Dir -> RIO env ()
runTemplateInits Path Abs Dir
dir = do
    Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
    case Config -> Maybe SCM
configScmInit Config
config of
        Maybe SCM
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just SCM
Git ->
            forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
[Char] -> m a -> m a
withWorkingDir (forall b t. Path b t -> [Char]
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) =>
[Char] -> [[Char]] -> (ProcessConfig () () () -> m a) -> m a
proc [Char]
"git" [[Char]
"init"] forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_)
                  (\SomeException
_ -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"git init failed to run, ignoring ...")

-- | Display help for the templates command.

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

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

-- Defaults


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

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

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

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

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

-- Exceptions


-- | Exception that might occur when making a new project.

data NewException
    = FailedToLoadTemplate !TemplateName
                           !FilePath
    | FailedToDownloadTemplate !TemplateName
                               !VerifiedDownloadException
    | AlreadyExists !(Path Abs Dir)
    | MissingParameters !PackageName !TemplateName !(Set String) !(Path Abs File)
    | InvalidTemplate !TemplateName !String
    | AttemptedOverwrites [Path Abs File]
    | FailedToDownloadTemplatesHelp !HttpException
    | BadTemplatesHelpEncoding
        !String -- URL it's downloaded from

        !UnicodeException
    | Can'tUseWiredInName !PackageName
    deriving (Typeable)

instance Exception NewException

instance Show NewException where
    show :: NewException -> [Char]
show (FailedToLoadTemplate TemplateName
name [Char]
path) =
        [Char]
"Failed to load download template " forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack (TemplateName -> Text
templateName TemplateName
name) forall a. Semigroup a => a -> a -> a
<>
        [Char]
" from " forall a. Semigroup a => a -> a -> a
<>
        [Char]
path
    show (FailedToDownloadTemplate TemplateName
name (DownloadHttpError HttpException
httpError)) =
          [Char]
"There was an unexpected HTTP error while downloading template " forall a. Semigroup a => a -> a -> a
<>
          Text -> [Char]
T.unpack (TemplateName -> Text
templateName TemplateName
name) forall a. Semigroup a => a -> a -> a
<> [Char]
": " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show HttpException
httpError
    show (FailedToDownloadTemplate TemplateName
name VerifiedDownloadException
_) =
        [Char]
"Failed to download template " forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack (TemplateName -> Text
templateName TemplateName
name) forall a. Semigroup a => a -> a -> a
<>
        [Char]
": unknown reason"

    show (AlreadyExists Path Abs Dir
path) =
        [Char]
"Directory " forall a. Semigroup a => a -> a -> a
<> forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
path forall a. Semigroup a => a -> a -> a
<> [Char]
" already exists. Aborting."
    show (MissingParameters PackageName
name TemplateName
template Set [Char]
missingKeys Path Abs File
userConfigPath) =
        forall a. [a] -> [[a]] -> [a]
intercalate
            [Char]
"\n"
            [ [Char]
"The following parameters were needed by the template but not provided: " forall a. Semigroup a => a -> a -> a
<>
              forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " (forall a. Set a -> [a]
S.toList Set [Char]
missingKeys)
            , [Char]
"You can provide them in " forall a. Semigroup a => a -> a -> a
<>
              forall b t. Path b t -> [Char]
toFilePath Path Abs File
userConfigPath forall a. Semigroup a => a -> a -> a
<>
              [Char]
", like this:"
            , [Char]
"templates:"
            , [Char]
"  params:"
            , forall a. [a] -> [[a]] -> [a]
intercalate
                  [Char]
"\n"
                  (forall a b. (a -> b) -> [a] -> [b]
map
                       (\[Char]
key ->
                             [Char]
"    " forall a. Semigroup a => a -> a -> a
<> [Char]
key forall a. Semigroup a => a -> a -> a
<> [Char]
": value")
                       (forall a. Set a -> [a]
S.toList Set [Char]
missingKeys))
            , [Char]
"Or you can pass each one as parameters like this:"
            , [Char]
"stack new " forall a. Semigroup a => a -> a -> a
<> PackageName -> [Char]
packageNameString PackageName
name forall a. Semigroup a => a -> a -> a
<> [Char]
" " forall a. Semigroup a => a -> a -> a
<>
              Text -> [Char]
T.unpack (TemplateName -> Text
templateName TemplateName
template) forall a. Semigroup a => a -> a -> a
<>
              [Char]
" " forall a. Semigroup a => a -> a -> a
<>
              [[Char]] -> [Char]
unwords
                  (forall a b. (a -> b) -> [a] -> [b]
map
                       (\[Char]
key ->
                             [Char]
"-p \"" forall a. Semigroup a => a -> a -> a
<> [Char]
key forall a. Semigroup a => a -> a -> a
<> [Char]
":value\"")
                       (forall a. Set a -> [a]
S.toList Set [Char]
missingKeys))]
    show (InvalidTemplate TemplateName
name [Char]
why) =
        [Char]
"The template \"" forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack (TemplateName -> Text
templateName TemplateName
name) forall a. Semigroup a => a -> a -> a
<>
        [Char]
"\" is invalid and could not be used. " forall a. Semigroup a => a -> a -> a
<>
        [Char]
"The error was: " forall a. Semigroup a => a -> a -> a
<> [Char]
why
    show (AttemptedOverwrites [Path Abs File]
fps) =
        [Char]
"The template would create the following files, but they already exist:\n" forall a. Semigroup a => a -> a -> a
<>
        [[Char]] -> [Char]
unlines (forall a b. (a -> b) -> [a] -> [b]
map (([Char]
"  " forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> [Char]
toFilePath) [Path Abs File]
fps) forall a. Semigroup a => a -> a -> a
<>
        [Char]
"Use --force to ignore this, and overwrite these files."
    show (FailedToDownloadTemplatesHelp HttpException
ex) =
        [Char]
"Failed to download `stack templates` help. The HTTP error was: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show HttpException
ex
    show (BadTemplatesHelpEncoding [Char]
url UnicodeException
err) =
        [Char]
"UTF-8 decoding error on template info from\n    " forall a. Semigroup a => a -> a -> a
<> [Char]
url forall a. Semigroup a => a -> a -> a
<> [Char]
"\n\n" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show UnicodeException
err
    show (Can'tUseWiredInName PackageName
name) =
        [Char]
"The name \"" forall a. Semigroup a => a -> a -> a
<> PackageName -> [Char]
packageNameString PackageName
name forall a. Semigroup a => a -> a -> a
<> [Char]
"\" is used by GHC wired-in packages, and so shouldn't be used as a package name"