#137 stack new now draws (by default) from commercialhaskell/stack-te…

…mplates

src/Stack/New.hs

@@ -1,34 +1,42 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module Stack.New
     ( newProject
     , NewOpts(..)
     ) where
 
-import           Control.Monad          (filterM, forM_, forM, unless)
+import           Control.Monad          (filterM, forM_, unless)
+import           Control.Monad.Catch    (MonadCatch, catch)
 import           Control.Monad.IO.Class (MonadIO, liftIO)
-import           Control.Monad.Logger   (MonadLogger, logInfo, logDebug, logError)
+import           Control.Monad.Logger   (MonadLogger, logInfo, logDebug)
+import           Control.Monad.Reader   (MonadReader, asks)
+import           Control.Monad.Trans.Writer (execWriterT)
 import           Data.ByteString        (ByteString)
-import qualified Data.ByteString        as S
-import           Data.FileEmbed         (embedDir)
-import qualified Data.List              as List
-import           Data.Map               (Map)
+import qualified Data.ByteString        as ByteString
+import qualified Data.ByteString.Lazy   as LByteString
+import           Data.Conduit           (($$), yield)
 import qualified Data.Map               as Map
 import           Data.Monoid            ((<>))
-import qualified Data.Text              as T
-import qualified Data.Text.Encoding     as T
-import qualified Data.Text.Lazy         as LT
+import qualified Data.Text              as Text
+import qualified Data.Text.Encoding     as Text
+import qualified Data.Text.Lazy         as LText
+import           Network.HTTP.Client    (HttpException, getUri)
+import           Network.HTTP.Download  (parseUrl, redownload, HasHttpManager)
+import           Path                   (parseRelFile, mkRelDir, toFilePath, (</>))
+import           Path.IO                (fileExists)
 import           System.Directory       (createDirectoryIfMissing,
                                          doesFileExist,
                                          getCurrentDirectory)
 import           System.FilePath        (takeDirectory,
                                          takeFileName,
                                          dropTrailingPathSeparator)
-import           System.Exit            (exitFailure)
 import           Text.Hastache
 import           Text.Hastache.Context
+import           Text.ProjectTemplate   (unpackTemplate, receiveMem)
 
 import           Stack.Init (InitOpts(forceOverwrite))
+import           Stack.Types.Config (HasStackRoot, getStackRoot)
 
 data NewOpts = NewOpts
     { newOptsTemplateRepository :: String
@@ -42,20 +50,35 @@ type Template = String
 defaultTemplate :: Template
 defaultTemplate = "new-template"
 
--- TODO(DanBurton): support multiple templates
--- Get the files associated with a given template
-getFiles :: (MonadIO m, MonadLogger m)
-         => String -> Template -> m (Map FilePath ByteString)
-getFiles _repo "new-template" = return $  Map.fromList $(embedDir "new-template")
-getFiles repo template = do
-    $logError $
-        "Error fetching template: " <> T.pack template <> "\n"
-        <> "     from repository: " <> T.pack repo <> "\n"
-        <> "\n"
-        <> "Sorry, only new-template is supported right now.\n"
-        <> "Support for more templates soon to come.\n"
-        <> "See: https://github.com/commercialhaskell/stack/issues/137"
-    liftIO exitFailure -- the end
+-- Get the files associated with a given template as a single ByteString.
+-- Templates are expected to be in "project-template" format.
+getFiles :: (MonadIO m, MonadLogger m, MonadCatch m, MonadReader env m, HasStackRoot env, HasHttpManager env)
+         => String -> Template -> m ByteString
+getFiles urlBase template = do
+    -- TODO(DanBurton): gracefully handle absence of trailing slash in urlBase.
+    -- TODO(DanBurton): gracefully handle urls with https:// already present.
+    let url = urlBase <> template <> ".hsfiles"
+    req <- parseUrl ("https://" <> url)
+
+    stackRoot <- asks getStackRoot
+    relFile <- parseRelFile url
+    let path = stackRoot </> $(mkRelDir "templates") </> relFile
+
+    let uriString = show $ getUri req
+    $logDebug "Attempting to redownload template"
+    downloaded <- redownload req path `catch` \(e :: HttpException) -> do
+        $logDebug $ "redownload failed for " <> Text.pack uriString
+        $logDebug $ "HttpException: " <> Text.pack (show e)
+        return False
+    exists <- fileExists path
+    unless exists $ error $ unlines
+        $ "Failed to download template:"
+        : uriString
+        : []
+    unless downloaded $ do
+        $logDebug "Using already-downloaded template."
+
+    liftIO $ ByteString.readFile (toFilePath path)
 
 -- Detect default key:value pairs for mustache template.
 getDefaultArgs :: (MonadIO m, MonadLogger m) => m [(String, String)]
@@ -72,53 +95,53 @@ toArgs = map toArg
         (key, ':':val) -> (key, val)
         _-> (s, "") -- TODO(DanBurton): Handle this error case better.
 
-newProject :: (MonadIO m, MonadLogger m)
+newProject :: (MonadIO m, MonadLogger m, MonadCatch m, MonadReader env m, HasStackRoot env, HasHttpManager env)
            => NewOpts
            -> m ()
 newProject newOpts = do
     let NewOpts repo templateMay args0 initOpts = newOpts
 
     $logDebug "Calculating template arguments"
     defaultArgs <- getDefaultArgs
+
     -- TODO(DanBurton): Do this logic in the arg parser instead.
     let (template, args1) = case templateMay of
             Nothing -> (defaultTemplate, args0)
             -- If the "template" arg has a colon, treat as arg instead.
             Just template0 -> case break (== ':') template0 of
                (_, []) -> (template0, args0)
                (_key, _colonVal) -> (defaultTemplate, template0:args0)
-    let args = toArgs args1 ++ defaultArgs
+
+    -- Note: this map prefers user-specified args over defaultArgs.
+    let args = Map.union
+            (Map.fromList $ toArgs args1)
+            (Map.fromList defaultArgs)
 
     $logDebug "Loading template files"
-    files <- getFiles repo template
+    filesBS <- getFiles repo template
 
-    let contextLookup key = case List.lookup key args of
+    let contextLookup key = case Map.lookup key args of
             Just val -> MuVariable val
             Nothing  -> MuNothing
 
-    let runHastache text =
-            hastacheStr defaultConfig text (mkStrContext contextLookup)
-
-    -- Render file paths and file contents via mustache.
-    -- There is some unsafety in `unMustache` on file names,
-    -- because file names could collide.
+    $logDebug "Rendering templates"
+    -- There is some unsafety in this regarding file names,
+    -- because interpolated file names could collide.
     -- I believe the correct way to handle this is to tell template creators
     -- to be careful to avoid this if they use mustache in file names.
     -- ~ Dan Burton
-    $logDebug "Rendering templates"
-    files' <- liftIO $ forM (Map.toList files) $ \(fp, bs) -> do
-        let fpText = T.pack fp
-        fpLText' <- runHastache fpText
-        let fp' = LT.unpack fpLText'
-
-        let bsText = T.decodeUtf8 bs
-        bsLText' <- runHastache bsText
-        let bs' = T.encodeUtf8 $ LT.toStrict bsLText'
+    filesLText <- hastacheStr
+        defaultConfig
+        (Text.decodeUtf8 filesBS)
+        (mkStrContext contextLookup)
+    let filesText = LText.toStrict filesLText
 
-        return (fp', bs')
+    files <- execWriterT
+         $ yield (Text.encodeUtf8 filesText)
+        $$ unpackTemplate receiveMem id
 
     $logDebug "Checking presence of template files"
-    exist <- filterM (liftIO . doesFileExist) (map fst files')
+    exist <- filterM (liftIO . doesFileExist) (Map.keys files)
     unless (forceOverwrite initOpts || null exist) $
        error $ unlines
            $ "The following files already exist, refusing to overwrite (no --force):"
@@ -127,8 +150,8 @@ newProject newOpts = do
     $logDebug "Writing template files"
     $logInfo ""
 
-    forM_ files' $ \(fp, bs) -> do
-        $logInfo $ T.pack $ "Writing: " ++ fp
+    forM_ (Map.toList files) $ \(fp, lbs) -> do
+        $logInfo $ Text.pack $ "Writing: " ++ fp
         liftIO $ do
             createDirectoryIfMissing True $ takeDirectory fp
-            S.writeFile fp bs
+            LByteString.writeFile fp lbs

src/Stack/Options.hs

@@ -528,9 +528,9 @@ newOptsParser =
             <*> initOptsParser
   where
     templateRepositoryParser = strOption
-         $ long "template-repository"
-        <> metavar "REPO"
-        <> value "https://github.com/commercialhaskell/stack-templates"
+         $ long "template-url-base"
+        <> metavar "URL"
+        <> value "raw.githubusercontent.com/commercialhaskell/stack-templates/master/"
     -- TODO(DanBurton): reject argument if it has a colon.
     templateParser = strArgument $ metavar "TEMPLATE"
     -- TODO(DanBurton): reject argument if it doesn't have a colon.

stack.cabal

@@ -23,16 +23,6 @@ extra-source-files:  README.md ChangeLog.md
                      test/package-dump/ghc-7.8.4-osx.txt
                      test/package-dump/ghc-7.10.txt
 
-                     new-template/src/Lib.hs
-                     -- new-template/{{name}}.cabal
-                     -- Cabal doesn't like curly braces.
-                     -- Luckily this can be described via glob.
-                     new-template/*.cabal
-                     new-template/test/Spec.hs
-                     new-template/app/Main.hs
-                     new-template/LICENSE
-                     new-template/Setup.hs
-
                      stack.yaml
 
 flag integration-tests
@@ -170,6 +160,7 @@ library
                    , file-embed
                    , word8
                    , hastache
+                   , project-template
   if !os(windows)
     build-depends:   unix >= 2.7.0.1
   default-language:    Haskell2010

stack.yaml

@@ -4,4 +4,5 @@ extra-deps:
 - path-0.5.2
 - Win32-notify-0.3.0.1
 - hfsevents-0.1.5
+- project-template-0.2.0
 resolver: lts-2.17