improve 'stack new'

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 {..}
 

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
@@ -27,9 +28,11 @@ 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
+import           Data.Maybe (fromMaybe)
 import           Data.Maybe.Extra (mapMaybeM)
 import           Data.Monoid
 import           Data.Set (Set)
@@ -45,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
@@ -62,27 +66,30 @@ 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.
     }
 
 -- | 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
     absDir <- if bare then return pwd
                       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
-            logUsing absDir
-            templateText <- loadTemplate template
+            templateText <- loadTemplate template (logUsing absDir template)
             files <-
                 applyTemplate
                     project
@@ -94,50 +101,69 @@ new opts = do
             runTemplateInits absDir
             return absDir
   where
-    template = newOptsTemplate opts
+    cliOptionTemplate = newOptsTemplate opts
     project = newOptsProjectName opts
     bare = newOptsCreateBare opts
-    logUsing absDir =
+    logUsing absDir template 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 " <>
              if bare then "the current directory"
                      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 =
+       (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
     case templatePath name of
-        Left absFile -> loadLocalFile absFile
-        Right relFile ->
+        AbsPath absFile -> logIt LocalTemp >> 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)
+                (loadLocalFile relFile <* logIt LocalTemp)
+                (\(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
+        $logDebug ("Opening local template: \"" <> T.pack (toFilePath path)
+                                                <> "\"")
         exists <- fileExists path
         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
+        logIt RemoteTemp
         _ <-
             catch
                 (redownload req path)
                 (throwM . FailedToDownloadTemplate name)
         loadLocalFile path
+    backupUrlRelPath = $(mkRelFile "downloaded.template.file.hsfiles")
 
 -- | Apply and unpack a template into a directory.
 applyTemplate

src/Stack/Options.hs

@@ -802,11 +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 subdirectory,\
-                  \ for example: foo or foo.hsfiles" <>
-             value defaultTemplateName) <*>
+             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")) <*>
         fmap
             M.fromList
             (many

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

src/Stack/Types/TemplateName.hs

@@ -7,18 +7,37 @@
 
 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
 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
+import           Prelude
 
 -- | 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)
+
+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
@@ -46,17 +65,19 @@ 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))
-    expected = "Expected a template filename like: foo or foo.hsfiles"
+    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 like: foo or foo.hsfiles or\
+               \ https://example.com/foo.hsfiles"
 
 -- | Make a template name.
 mkTemplateName :: String -> Q Exp
@@ -67,13 +88,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

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