{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
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
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
}
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
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)
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
, :: 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
}
settingsFromRepoTemplatePath :: RepoTemplatePath -> TemplateDownloadSettings
settingsFromRepoTemplatePath :: RepoTemplatePath -> TemplateDownloadSettings
settingsFromRepoTemplatePath (RepoTemplatePath RepoService
GitHub Text
user Text
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]
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")
let applyMustache :: ByteString -> m (ByteString, Set [Char])
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 = [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)
| Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString
bytes, forall a. Set a
S.empty)
processFile :: Set [Char]
-> ([Char], ByteString)
-> m (Set [Char], (Path Abs File, ByteString))
processFile Set [Char]
mks ([Char]
fpOrig, ByteString
bytes) = do
(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)
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)
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 (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 ...")
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
defaultRepoService :: RepoService
defaultRepoService :: RepoService
defaultRepoService = RepoService
GitHub
defaultTemplatesHelpUrl :: String
defaultTemplatesHelpUrl :: [Char]
defaultTemplatesHelpUrl =
[Char]
"https://raw.githubusercontent.com/commercialhaskell/stack-templates/master/STACK_HELP.md"
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
!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"