From 25fe7eed3ccfbbac539d9fc4e829cbec7116317d Mon Sep 17 00:00:00 2001 From: Joshua Simmons Date: Wed, 16 Dec 2015 20:24:28 -0700 Subject: [PATCH 1/9] improve wording of template name help --- src/Stack/Options.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs index 62379366c5..2d993141cd 100644 --- a/src/Stack/Options.hs +++ b/src/Stack/Options.hs @@ -804,7 +804,7 @@ newOptsParser = (,) <$> newOpts <*> initOptsParser help "Do not create a subdirectory for the project") <*> templateNameArgument (metavar "TEMPLATE_NAME" <> - help "Name of a template or a local template in a subdirectory,\ + help "Name of a template or a local template in a file,\ \ for example: foo or foo.hsfiles" <> value defaultTemplateName) <*> fmap From e39e14e91c0afbdafd7aca26a32936be690d6877 Mon Sep 17 00:00:00 2001 From: Joshua Simmons Date: Wed, 16 Dec 2015 23:09:53 -0700 Subject: [PATCH 2/9] change the type of TemplateName to handle URLs too --- src/Stack/Types/TemplateName.hs | 40 ++++++++++++++++++++++----------- stack.cabal | 1 + 2 files changed, 28 insertions(+), 13 deletions(-) diff --git a/src/Stack/Types/TemplateName.hs b/src/Stack/Types/TemplateName.hs index 66da7058f1..94fd4c4b0e 100644 --- a/src/Stack/Types/TemplateName.hs +++ b/src/Stack/Types/TemplateName.hs @@ -7,18 +7,30 @@ module Stack.Types.TemplateName where +import Control.Error.Safe (justErr) +import Data.Foldable (asum) import Data.Monoid import Data.Text (Text) import qualified Data.Text as T import Language.Haskell.TH +import Network.HTTP.Client (parseUrl) import qualified Options.Applicative as O import Path import Path.Internal -- | A template name. -data TemplateName = TemplateName !Text !(Either (Path Abs File) (Path Rel File)) +data TemplateName = TemplateName !Text !TemplatePath deriving (Ord,Eq,Show) +data TemplatePath = AbsPath (Path Abs File) + -- ^ an absolute path on the filesystem + | RelPath (Path Rel File) + -- ^ a relative path on the filesystem, or relative to + -- the template repository + | UrlPath String + -- ^ a full URL + deriving (Eq, Ord, Show) + -- | An argument which accepts a template name of the format -- @foo.hsfiles@ or @foo@, ultimately normalized to @foo@. templateNameArgument :: O.Mod O.ArgumentFields TemplateName @@ -46,16 +58,17 @@ templateParamArgument = parseTemplateNameFromString :: String -> Either String TemplateName parseTemplateNameFromString fname = case T.stripSuffix ".hsfiles" (T.pack fname) of - Nothing -> parseValidFile (T.pack fname) (fname <> ".hsfiles") - Just prefix -> parseValidFile prefix fname + Nothing -> parseValidFile (T.pack fname) (fname <> ".hsfiles") fname + Just prefix -> parseValidFile prefix fname fname where - parseValidFile prefix str = - case parseRelFile str of - Nothing -> - case parseAbsFile str of - Nothing -> Left expected - Just fp -> return (TemplateName prefix (Left fp)) - Just fp -> return (TemplateName prefix (Right fp)) + parseValidFile prefix hsf orig = justErr expected + $ asum (validParses prefix hsf orig) + validParses prefix hsf orig = + -- NOTE: order is important + [ TemplateName (T.pack orig) . UrlPath <$> (parseUrl orig *> Just orig) + , TemplateName prefix . AbsPath <$> parseAbsFile hsf + , TemplateName prefix . RelPath <$> parseRelFile hsf + ] expected = "Expected a template filename like: foo or foo.hsfiles" -- | Make a template name. @@ -67,13 +80,14 @@ mkTemplateName s = [|TemplateName (T.pack prefix) $(pn)|] where pn = case p of - Left (Path fp) -> [|Left (Path fp)|] - Right (Path fp) -> [|Right (Path fp)|] + AbsPath (Path fp) -> [|AbsPath (Path fp)|] + RelPath (Path fp) -> [|RelPath (Path fp)|] + UrlPath fp -> [|UrlPath fp|] -- | Get a text representation of the template name. templateName :: TemplateName -> Text templateName (TemplateName prefix _) = prefix -- | Get the path of the template. -templatePath :: TemplateName -> Either (Path Abs File) (Path Rel File) +templatePath :: TemplateName -> TemplatePath templatePath (TemplateName _ fp) = fp diff --git a/stack.cabal b/stack.cabal index 99b211ede2..e6a81521e5 100644 --- a/stack.cabal +++ b/stack.cabal @@ -151,6 +151,7 @@ library , edit-distance >= 0.2 , either , enclosed-exceptions + , errors , exceptions >= 0.8.0.2 , extra , fast-logger >= 2.3.1 From ab7bb1b1ddd78d86cd23411b143237f53a7bc621 Mon Sep 17 00:00:00 2001 From: Joshua Simmons Date: Thu, 17 Dec 2015 00:46:39 -0700 Subject: [PATCH 3/9] implement explicit URL downloading in 'stack new' closes #1466 --- src/Stack/New.hs | 33 ++++++++++++++++++++++----------- 1 file changed, 22 insertions(+), 11 deletions(-) diff --git a/src/Stack/New.hs b/src/Stack/New.hs index e506640b7c..95185a3a55 100644 --- a/src/Stack/New.hs +++ b/src/Stack/New.hs @@ -30,6 +30,7 @@ import Data.Conduit import Data.List import Data.Map.Strict (Map) import qualified Data.Map.Strict as M +import Data.Maybe (fromMaybe) import Data.Maybe.Extra (mapMaybeM) import Data.Monoid import Data.Set (Set) @@ -112,14 +113,25 @@ loadTemplate :: forall m r. (HasConfig r, HasHttpManager r, MonadReader r m, MonadIO m, MonadThrow m, MonadCatch m) => TemplateName -> m Text -loadTemplate name = +loadTemplate name = do + templateDir <- templatesDir <$> asks getConfig case templatePath name of - Left absFile -> loadLocalFile absFile - Right relFile -> + AbsPath absFile -> loadLocalFile absFile + UrlPath s -> do + let req = fromMaybe (error "impossible happened: already valid \ + \URL couldn't be parsed") + (parseUrl s) + rel = fromMaybe backupUrlRelPath (parseRelFile s) + downloadTemplate req (templateDir rel) + RelPath relFile -> catch (loadLocalFile relFile) - (\(_ :: NewException) -> - downloadTemplate relFile) + (\(e :: NewException) -> + case relRequest relFile of + Just req -> downloadTemplate req + (templateDir relFile) + Nothing -> throwM e + ) where loadLocalFile :: Path b File -> m Text loadLocalFile path = do @@ -127,17 +139,16 @@ loadTemplate name = if exists then liftIO (T.readFile (toFilePath path)) else throwM (FailedToLoadTemplate name (toFilePath path)) - downloadTemplate :: Path Rel File -> m Text - downloadTemplate rel = do - config <- asks getConfig - req <- parseUrl (defaultTemplateUrl <> "/" <> toFilePath rel) - let path :: Path Abs File - path = templatesDir config rel + relRequest :: MonadThrow n => Path Rel File -> n Request + relRequest rel = parseUrl (defaultTemplateUrl <> "/" <> toFilePath rel) + downloadTemplate :: Request -> Path Abs File -> m Text + downloadTemplate req path = do _ <- catch (redownload req path) (throwM . FailedToDownloadTemplate name) loadLocalFile path + backupUrlRelPath = $(mkRelFile "downloaded.template.file.hsfiles") -- | Apply and unpack a template into a directory. applyTemplate From 91de5f2d61dca06928324752680975d4cbc3da5b Mon Sep 17 00:00:00 2001 From: Joshua Simmons Date: Thu, 17 Dec 2015 01:21:35 -0700 Subject: [PATCH 4/9] update help documentation for URLs in 'stack new' --- src/Stack/Options.hs | 5 +++-- src/Stack/Types/TemplateName.hs | 3 ++- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs index 2d993141cd..cee40d74c7 100644 --- a/src/Stack/Options.hs +++ b/src/Stack/Options.hs @@ -804,8 +804,9 @@ newOptsParser = (,) <$> newOpts <*> initOptsParser help "Do not create a subdirectory for the project") <*> templateNameArgument (metavar "TEMPLATE_NAME" <> - help "Name of a template or a local template in a file,\ - \ for example: foo or foo.hsfiles" <> + help "Name of a template or a local template in a file or a URL.\ + \ For example: foo or foo.hsfiles or ~/foo or\ + \ https://example.com/foo.hsfiles" <> value defaultTemplateName) <*> fmap M.fromList diff --git a/src/Stack/Types/TemplateName.hs b/src/Stack/Types/TemplateName.hs index 94fd4c4b0e..7ed9fd83fc 100644 --- a/src/Stack/Types/TemplateName.hs +++ b/src/Stack/Types/TemplateName.hs @@ -69,7 +69,8 @@ parseTemplateNameFromString fname = , TemplateName prefix . AbsPath <$> parseAbsFile hsf , TemplateName prefix . RelPath <$> parseRelFile hsf ] - expected = "Expected a template filename like: foo or foo.hsfiles" + expected = "Expected a template like: foo or foo.hsfiles or\ + \ https://example.com/foo.hsfiles" -- | Make a template name. mkTemplateName :: String -> Q Exp From ef47f9baad1a25de637e4c73e157bc5596122279 Mon Sep 17 00:00:00 2001 From: Joshua Simmons Date: Thu, 17 Dec 2015 08:05:14 -0700 Subject: [PATCH 5/9] improve logging in 'stack new' - don't say we're "Downloading" a local file - logDebug what file we're opening --- src/Stack/New.hs | 27 ++++++++++++++++++--------- 1 file changed, 18 insertions(+), 9 deletions(-) diff --git a/src/Stack/New.hs b/src/Stack/New.hs index 95185a3a55..23887089e8 100644 --- a/src/Stack/New.hs +++ b/src/Stack/New.hs @@ -82,8 +82,7 @@ new opts = do if exists && not bare then throwM (AlreadyExists absDir) else do - logUsing absDir - templateText <- loadTemplate template + templateText <- loadTemplate template (logUsing absDir) files <- applyTemplate project @@ -98,9 +97,13 @@ new opts = do template = newOptsTemplate opts project = newOptsProjectName opts bare = newOptsCreateBare opts - logUsing absDir = + logUsing absDir templateFrom = + let loading = case templateFrom of + LocalTemp -> "Loading local" + RemoteTemp -> "Downloading" + in $logInfo - ("Downloading template \"" <> templateName template <> + (loading <> " template \"" <> templateName template <> "\" to create project \"" <> packageNameText project <> "\" in " <> @@ -108,15 +111,17 @@ new opts = do else T.pack (toFilePath (dirname absDir)) <> " ...") +data TemplateFrom = LocalTemp | RemoteTemp + -- | Download and read in a template's text content. loadTemplate :: forall m r. - (HasConfig r, HasHttpManager r, MonadReader r m, MonadIO m, MonadThrow m, MonadCatch m) - => TemplateName -> m Text -loadTemplate name = do + (HasConfig r, HasHttpManager r, MonadReader r m, MonadIO m, MonadThrow m, MonadCatch m, MonadLogger m) + => TemplateName -> (TemplateFrom -> m ()) -> m Text +loadTemplate name logIt = do templateDir <- templatesDir <$> asks getConfig case templatePath name of - AbsPath absFile -> loadLocalFile absFile + AbsPath absFile -> logIt LocalTemp >> loadLocalFile absFile UrlPath s -> do let req = fromMaybe (error "impossible happened: already valid \ \URL couldn't be parsed") @@ -125,7 +130,7 @@ loadTemplate name = do downloadTemplate req (templateDir rel) RelPath relFile -> catch - (loadLocalFile relFile) + (loadLocalFile relFile <* logIt LocalTemp) (\(e :: NewException) -> case relRequest relFile of Just req -> downloadTemplate req @@ -135,7 +140,10 @@ loadTemplate name = do where loadLocalFile :: Path b File -> m Text loadLocalFile path = do + $logDebug ("Opening local template: \"" <> T.pack (toFilePath path) + <> "\"") exists <- fileExists path + unless exists ($logDebug "Template file doesn't exist") if exists then liftIO (T.readFile (toFilePath path)) else throwM (FailedToLoadTemplate name (toFilePath path)) @@ -143,6 +151,7 @@ loadTemplate name = do relRequest rel = parseUrl (defaultTemplateUrl <> "/" <> toFilePath rel) downloadTemplate :: Request -> Path Abs File -> m Text downloadTemplate req path = do + logIt RemoteTemp _ <- catch (redownload req path) From f313e04511f771c0c9f08536303e6c54fc4b13bc Mon Sep 17 00:00:00 2001 From: Joshua Simmons Date: Thu, 17 Dec 2015 15:10:15 -0700 Subject: [PATCH 6/9] add a default-template config option --- src/Stack/Config.hs | 1 + src/Stack/Types/Config.hs | 13 +++++++++++++ src/Stack/Types/TemplateName.hs | 5 +++++ 3 files changed, 19 insertions(+) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 2450e424ba..e6d41a884e 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -204,6 +204,7 @@ configFromConfigMonoid configStackRoot configUserConfigPath mresolver mproject c configRebuildGhcOptions = fromMaybe False configMonoidRebuildGhcOptions configApplyGhcOptions = fromMaybe AGOLocals configMonoidApplyGhcOptions configAllowNewer = fromMaybe False configMonoidAllowNewer + configDefaultTemplate = configMonoidDefaultTemplate return Config {..} diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 45bbf51ffa..50120bdfb4 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -167,6 +167,7 @@ import Stack.Types.Image import Stack.Types.PackageIdentifier import Stack.Types.PackageIndex import Stack.Types.PackageName +import Stack.Types.TemplateName import Stack.Types.Version import System.PosixCompat.Types (UserID, GroupID) import System.Process.Read (EnvOverride) @@ -273,6 +274,9 @@ data Config = ,configAllowNewer :: !Bool -- ^ Ignore version ranges in .cabal files. Funny naming chosen to -- match cabal. + ,configDefaultTemplate :: !(Maybe TemplateName) + -- ^ The default template to use when none is specified. + -- (If Nothing, the default default is used.) } -- | Which packages to ghc-options on the command line apply to? @@ -793,6 +797,9 @@ data ConfigMonoid = -- ^ See 'configApplyGhcOptions' ,configMonoidAllowNewer :: !(Maybe Bool) -- ^ See 'configMonoidAllowNewer' + ,configMonoidDefaultTemplate :: !(Maybe TemplateName) + -- ^ The default template to use when none is specified. + -- (If Nothing, the default default is used.) } deriving Show @@ -831,6 +838,7 @@ instance Monoid ConfigMonoid where , configMonoidRebuildGhcOptions = Nothing , configMonoidApplyGhcOptions = Nothing , configMonoidAllowNewer = Nothing + , configMonoidDefaultTemplate = Nothing } mappend l r = ConfigMonoid { configMonoidWorkDir = configMonoidWorkDir l <|> configMonoidWorkDir r @@ -867,6 +875,7 @@ instance Monoid ConfigMonoid where , configMonoidRebuildGhcOptions = configMonoidRebuildGhcOptions l <|> configMonoidRebuildGhcOptions r , configMonoidApplyGhcOptions = configMonoidApplyGhcOptions l <|> configMonoidApplyGhcOptions r , configMonoidAllowNewer = configMonoidAllowNewer l <|> configMonoidAllowNewer r + , configMonoidDefaultTemplate = configMonoidDefaultTemplate l <|> configMonoidDefaultTemplate r } instance FromJSON (ConfigMonoid, [JSONWarning]) where @@ -930,6 +939,7 @@ parseConfigMonoidJSON obj = do configMonoidRebuildGhcOptions <- obj ..:? configMonoidRebuildGhcOptionsName configMonoidApplyGhcOptions <- obj ..:? configMonoidApplyGhcOptionsName configMonoidAllowNewer <- obj ..:? configMonoidAllowNewerName + configMonoidDefaultTemplate <- obj ..:? configMonoidDefaultTemplateName return ConfigMonoid {..} where @@ -1055,6 +1065,9 @@ configMonoidApplyGhcOptionsName = "apply-ghc-options" configMonoidAllowNewerName :: Text configMonoidAllowNewerName = "allow-newer" +configMonoidDefaultTemplateName :: Text +configMonoidDefaultTemplateName = "default-template" + data ConfigException = ParseConfigFileException (Path Abs File) ParseException | ParseResolverException Text diff --git a/src/Stack/Types/TemplateName.hs b/src/Stack/Types/TemplateName.hs index 7ed9fd83fc..ec85239453 100644 --- a/src/Stack/Types/TemplateName.hs +++ b/src/Stack/Types/TemplateName.hs @@ -8,6 +8,7 @@ module Stack.Types.TemplateName where import Control.Error.Safe (justErr) +import Data.Aeson.Extended (FromJSON, withText, parseJSON) import Data.Foldable (asum) import Data.Monoid import Data.Text (Text) @@ -31,6 +32,10 @@ data TemplatePath = AbsPath (Path Abs File) -- ^ a full URL deriving (Eq, Ord, Show) +instance FromJSON TemplateName where + parseJSON = withText "TemplateName" $ + either fail return . parseTemplateNameFromString . T.unpack + -- | An argument which accepts a template name of the format -- @foo.hsfiles@ or @foo@, ultimately normalized to @foo@. templateNameArgument :: O.Mod O.ArgumentFields TemplateName From 2ad15e612e9d71aa5bf4ce264b31063bf44d8b8d Mon Sep 17 00:00:00 2001 From: Joshua Simmons Date: Thu, 17 Dec 2015 15:30:54 -0700 Subject: [PATCH 7/9] use configured default template if none is provided --- src/Stack/New.hs | 13 +++++++++---- src/Stack/Options.hs | 5 ++--- 2 files changed, 11 insertions(+), 7 deletions(-) diff --git a/src/Stack/New.hs b/src/Stack/New.hs index 23887089e8..923ba563e9 100644 --- a/src/Stack/New.hs +++ b/src/Stack/New.hs @@ -27,6 +27,7 @@ import Data.Aeson.Types import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString.Lazy.Char8 as L8 import Data.Conduit +import Data.Foldable (asum) import Data.List import Data.Map.Strict (Map) import qualified Data.Map.Strict as M @@ -63,7 +64,7 @@ data NewOpts = NewOpts -- ^ Name of the project to create. , newOptsCreateBare :: Bool -- ^ Whether to create the project without a directory. - , newOptsTemplate :: TemplateName + , newOptsTemplate :: Maybe TemplateName -- ^ Name of the template to use. , newOptsNonceParams :: Map Text Text -- ^ Nonce parameters specified just for this invocation. @@ -79,10 +80,14 @@ new opts = do else do relDir <- parseRelDir (packageNameString project) liftM (pwd ) (return relDir) exists <- dirExists absDir + configTemplate <- configDefaultTemplate <$> asks getConfig + let template = fromMaybe defaultTemplateName $ asum [ cliOptionTemplate + , configTemplate + ] if exists && not bare then throwM (AlreadyExists absDir) else do - templateText <- loadTemplate template (logUsing absDir) + templateText <- loadTemplate template (logUsing absDir template) files <- applyTemplate project @@ -94,10 +99,10 @@ new opts = do runTemplateInits absDir return absDir where - template = newOptsTemplate opts + cliOptionTemplate = newOptsTemplate opts project = newOptsProjectName opts bare = newOptsCreateBare opts - logUsing absDir templateFrom = + logUsing absDir template templateFrom = let loading = case templateFrom of LocalTemp -> "Loading local" RemoteTemp -> "Downloading" diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs index cee40d74c7..8d50be388f 100644 --- a/src/Stack/Options.hs +++ b/src/Stack/Options.hs @@ -802,12 +802,11 @@ newOptsParser = (,) <$> newOpts <*> initOptsParser switch (long "bare" <> help "Do not create a subdirectory for the project") <*> - templateNameArgument + optional (templateNameArgument (metavar "TEMPLATE_NAME" <> help "Name of a template or a local template in a file or a URL.\ \ For example: foo or foo.hsfiles or ~/foo or\ - \ https://example.com/foo.hsfiles" <> - value defaultTemplateName) <*> + \ https://example.com/foo.hsfiles")) <*> fmap M.fromList (many From 1606fab8911235eeb5eb786e706a57d2b12527ba Mon Sep 17 00:00:00 2001 From: Joshua Simmons Date: Thu, 17 Dec 2015 17:07:47 -0700 Subject: [PATCH 8/9] fix building in GHC 7.8 --- src/Stack/New.hs | 6 ++++-- src/Stack/Types/TemplateName.hs | 2 ++ 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/src/Stack/New.hs b/src/Stack/New.hs index 923ba563e9..fb0d7365c9 100644 --- a/src/Stack/New.hs +++ b/src/Stack/New.hs @@ -16,6 +16,7 @@ module Stack.New , listTemplates) where +import Control.Applicative import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class @@ -47,6 +48,7 @@ import Network.HTTP.Download import Network.HTTP.Types.Status import Path import Path.IO +import Prelude import Stack.Constants import Stack.Types import Stack.Types.TemplateName @@ -72,7 +74,7 @@ data NewOpts = NewOpts -- | Create a new project with the given options. new - :: (HasConfig r, MonadReader r m, MonadLogger m, MonadCatch m, MonadThrow m, MonadIO m, HasHttpManager r) + :: (HasConfig r, MonadReader r m, MonadLogger m, MonadCatch m, MonadThrow m, MonadIO m, HasHttpManager r, Functor m, Applicative m) => NewOpts -> m (Path Abs Dir) new opts = do pwd <- getWorkingDir @@ -121,7 +123,7 @@ data TemplateFrom = LocalTemp | RemoteTemp -- | Download and read in a template's text content. loadTemplate :: forall m r. - (HasConfig r, HasHttpManager r, MonadReader r m, MonadIO m, MonadThrow m, MonadCatch m, MonadLogger m) + (HasConfig r, HasHttpManager r, MonadReader r m, MonadIO m, MonadThrow m, MonadCatch m, MonadLogger m, Functor m, Applicative m) => TemplateName -> (TemplateFrom -> m ()) -> m Text loadTemplate name logIt = do templateDir <- templatesDir <$> asks getConfig diff --git a/src/Stack/Types/TemplateName.hs b/src/Stack/Types/TemplateName.hs index ec85239453..6c68033d48 100644 --- a/src/Stack/Types/TemplateName.hs +++ b/src/Stack/Types/TemplateName.hs @@ -8,6 +8,7 @@ module Stack.Types.TemplateName where import Control.Error.Safe (justErr) +import Control.Applicative import Data.Aeson.Extended (FromJSON, withText, parseJSON) import Data.Foldable (asum) import Data.Monoid @@ -18,6 +19,7 @@ import Network.HTTP.Client (parseUrl) import qualified Options.Applicative as O import Path import Path.Internal +import Prelude -- | A template name. data TemplateName = TemplateName !Text !TemplatePath From 2ecb37fcc27056faee5586a183aeb5a745c42d1b Mon Sep 17 00:00:00 2001 From: Joshua Simmons Date: Thu, 17 Dec 2015 20:35:58 -0700 Subject: [PATCH 9/9] remove redundant logDebug when template file doesn't exist --- src/Stack/New.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Stack/New.hs b/src/Stack/New.hs index fb0d7365c9..a7d3812c45 100644 --- a/src/Stack/New.hs +++ b/src/Stack/New.hs @@ -150,7 +150,6 @@ loadTemplate name logIt = do $logDebug ("Opening local template: \"" <> T.pack (toFilePath path) <> "\"") exists <- fileExists path - unless exists ($logDebug "Template file doesn't exist") if exists then liftIO (T.readFile (toFilePath path)) else throwM (FailedToLoadTemplate name (toFilePath path))