Merge remote-tracking branch 'origin/master' into remove-terminal-size

src/Network/HTTP/StackClient.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
-
+{-# LANGUAGE LambdaCase        #-}
 -- |
 -- Wrapper functions of 'Network.HTTP.Simple' and 'Network.HTTP.Client' to
 -- add the 'User-Agent' HTTP request header to each request.
@@ -43,17 +43,24 @@ module Network.HTTP.StackClient
   , download
   , redownload
   , verifiedDownload
+  , verifiedDownloadWithProgress
   , CheckHexDigest (..)
   , DownloadRequest (..)
   , drRetryPolicyDefault
   , DownloadException (..)
   , HashCheck (..)
   ) where
 
+import           Control.Monad.State (get, put, modify)
 import           Data.Aeson (FromJSON)
 import qualified Data.ByteString as Strict
-import           Data.Conduit (ConduitM)
+import           Data.Conduit (ConduitM, ConduitT, awaitForever, (.|), yield, await)
+import           Data.Conduit.Lift (evalStateC)
+import qualified Data.Conduit.List as CL
 import           Data.Void (Void)
+import           Data.Monoid (Sum (..))
+import qualified Data.Text as T
+import           Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime)
 import           Network.HTTP.Client (Request, RequestBody(..), Response, parseRequest, getUri, path, checkResponse, parseUrlThrow)
 import           Network.HTTP.Simple (setRequestMethod, setRequestBody, setRequestHeader, addRequestHeader, HttpException(..), getResponseBody, getResponseStatusCode, getResponseHeaders)
 import           Network.HTTP.Types (hAccept, hContentLength, hContentMD5, methodPut)
@@ -64,8 +71,10 @@ import qualified Network.HTTP.Download as Download
 import qualified Network.HTTP.Simple
 import           Network.HTTP.Client.MultipartFormData (formDataBody, partFileRequestBody, partBS, partLBS)
 import           Path
+import           Prelude (until, (!!))
 import           RIO
 import           RIO.PrettyPrint
+import           Text.Printf (printf)
 
 
 setUserAgent :: Request -> Request
@@ -145,3 +154,96 @@ verifiedDownload dr destpath progressSink =
     Download.verifiedDownload dr' destpath progressSink
   where
     dr' = dr {drRequest = setUserAgent (drRequest dr)}
+
+verifiedDownloadWithProgress
+  :: HasTerm env
+  => DownloadRequest
+  -> Path Abs File
+  -> Text
+  -> Maybe Int
+  -> RIO env Bool
+verifiedDownloadWithProgress req destpath lbl msize =
+  verifiedDownload req destpath (chattyDownloadProgress lbl msize)
+
+chattyDownloadProgress
+  :: ( HasLogFunc env
+     , MonadIO m
+     , MonadReader env m
+     )
+  => Text
+  -> Maybe Int
+  -> f
+  -> ConduitT ByteString c m ()
+chattyDownloadProgress label mtotalSize _ = do
+    _ <- logSticky $ RIO.display label <> ": download has begun"
+    CL.map (Sum . Strict.length)
+      .| chunksOverTime 1
+      .| go
+  where
+    go = evalStateC 0 $ awaitForever $ \(Sum size) -> do
+        modify (+ size)
+        totalSoFar <- get
+        logSticky $ fromString $
+            case mtotalSize of
+                Nothing -> chattyProgressNoTotal totalSoFar
+                Just 0 -> chattyProgressNoTotal totalSoFar
+                Just totalSize -> chattyProgressWithTotal totalSoFar totalSize
+
+    -- Example: ghc: 42.13 KiB downloaded...
+    chattyProgressNoTotal totalSoFar =
+        printf ("%s: " <> bytesfmt "%7.2f" totalSoFar <> " downloaded...")
+                (T.unpack label)
+
+    -- Example: ghc: 50.00 MiB / 100.00 MiB (50.00%) downloaded...
+    chattyProgressWithTotal totalSoFar total =
+      printf ("%s: " <>
+              bytesfmt "%7.2f" totalSoFar <> " / " <>
+              bytesfmt "%.2f" total <>
+              " (%6.2f%%) downloaded...")
+              (T.unpack label)
+              percentage
+      where percentage :: Double
+            percentage = fromIntegral totalSoFar / fromIntegral total * 100
+
+-- | Given a printf format string for the decimal part and a number of
+-- bytes, formats the bytes using an appropriate unit and returns the
+-- formatted string.
+--
+-- >>> bytesfmt "%.2" 512368
+-- "500.359375 KiB"
+bytesfmt :: Integral a => String -> a -> String
+bytesfmt formatter bs = printf (formatter <> " %s")
+                               (fromIntegral (signum bs) * dec :: Double)
+                               (bytesSuffixes !! i)
+  where
+    (dec,i) = getSuffix (abs bs)
+    getSuffix n = until p (\(x,y) -> (x / 1024, y+1)) (fromIntegral n,0)
+      where p (n',numDivs) = n' < 1024 || numDivs == (length bytesSuffixes - 1)
+    bytesSuffixes :: [String]
+    bytesSuffixes = ["B","KiB","MiB","GiB","TiB","PiB","EiB","ZiB","YiB"]
+
+-- Await eagerly (collect with monoidal append),
+-- but space out yields by at least the given amount of time.
+-- The final yield may come sooner, and may be a superfluous mempty.
+-- Note that Integer and Float literals can be turned into NominalDiffTime
+-- (these literals are interpreted as "seconds")
+chunksOverTime :: (Monoid a, Semigroup a, MonadIO m) => NominalDiffTime -> ConduitM a a m ()
+chunksOverTime diff = do
+    currentTime <- liftIO getCurrentTime
+    evalStateC (currentTime, mempty) go
+  where
+    -- State is a tuple of:
+    -- * the last time a yield happened (or the beginning of the sink)
+    -- * the accumulated awaits since the last yield
+    go = await >>= \case
+      Nothing -> do
+        (_, acc) <- get
+        yield acc
+      Just a -> do
+        (lastTime, acc) <- get
+        let acc' = acc <> a
+        currentTime <- liftIO getCurrentTime
+        if diff < diffUTCTime currentTime lastTime
+          then put (currentTime, mempty) >> yield acc'
+          else put (lastTime,    acc')
+        go

src/Stack/New.hs

@@ -30,15 +30,17 @@ 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 (DownloadException (..), Request, HttpException,
-                                           getResponseStatusCode, getResponseBody, httpLbs,
-                                           parseRequest, parseUrlThrow, redownload, setGithubHeaders)
+import           Network.HTTP.StackClient (DownloadRequest (..), DownloadException (..), Request, HttpException,
+                                           drRetryPolicyDefault, getResponseStatusCode, getResponseBody, httpLbs,
+                                           parseRequest, parseUrlThrow, verifiedDownloadWithProgress, setGithubHeaders)
 import           Path
 import           Path.IO
 import           Stack.Constants
 import           Stack.Constants.Config
 import           Stack.Types.Config
 import           Stack.Types.TemplateName
+import           System.PosixCompat.Files (getFileStatus, fileSize)
+import           System.Posix.Types (COff (..))
 import           RIO.Process
 import qualified Text.Mustache as Mustache
 import qualified Text.Mustache.Render as Mustache
@@ -155,9 +157,20 @@ loadTemplate name logIt = do
         downloadTemplate req (templateDir </> rel)
     downloadTemplate :: Request -> Path Abs File -> RIO env Text
     downloadTemplate req path = do
+        fs <- liftIO $ getFileStatus (toFilePath path)
+        let (COff size) = fileSize fs
+            downloadFileSize = fromIntegral size
+            dReq = DownloadRequest
+              { drRequest = req
+              , drHashChecks = []
+              , drLengthCheck = Just downloadFileSize
+              , drRetryPolicy = drRetryPolicyDefault
+              }
         logIt RemoteTemp
         catch
-          (void $ redownload req path)
+          (void $
+            verifiedDownloadWithProgress dReq path (T.pack $ toFilePath path) (Just downloadFileSize)
+          )
           (useCachedVersionOrThrow path)
 
         loadLocalFile path

src/Stack/Setup.hs

@@ -31,14 +31,12 @@ module Stack.Setup
 import qualified    Codec.Archive.Tar as Tar
 import              Conduit
 import              Control.Applicative (empty)
-import              Control.Monad.State (get, put, modify)
 import "cryptonite" Crypto.Hash (SHA1(..), SHA256(..))
 import              Pantry.Internal.AesonExtended
 import qualified    Data.ByteString as S
 import qualified    Data.ByteString.Lazy as LBS
 import qualified    Data.Conduit.Binary as CB
 import              Data.Conduit.Lazy (lazyConsume)
-import              Data.Conduit.Lift (evalStateC)
 import qualified    Data.Conduit.List as CL
 import              Data.Conduit.Process.Typed (createSource)
 import              Data.Conduit.Zlib          (ungzip)
@@ -50,7 +48,6 @@ import qualified    Data.Set as Set
 import qualified    Data.Text as T
 import qualified    Data.Text.Encoding as T
 import qualified    Data.Text.Encoding.Error as T
-import              Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime)
 import qualified    Data.Yaml as Yaml
 import              Distribution.System (OS, Arch (..), Platform (..))
 import qualified    Distribution.System as Cabal
@@ -61,12 +58,11 @@ import              Lens.Micro (set)
 import              Network.HTTP.StackClient (CheckHexDigest (..), DownloadRequest (..), HashCheck (..),
                                               drRetryPolicyDefault, getResponseBody, getResponseStatusCode,
                                               httpLbs, httpJSON, parseRequest, parseUrlThrow, setGithubHeaders,
-                                              verifiedDownload, withResponse)
+                                              verifiedDownloadWithProgress, withResponse)
 import              Path
 import              Path.CheckInstall (warnInstallSearchPathIssues)
 import              Path.Extra (toFilePathNoTrailingSep)
 import              Path.IO hiding (findExecutable, withSystemTempDir)
-import              Prelude (until)
 import qualified    Pantry
 import qualified    RIO
 import              RIO.List
@@ -95,7 +91,6 @@ import              System.IO.Error (isPermissionError)
 import              System.FilePath (searchPathSeparator)
 import qualified    System.FilePath as FP
 import              System.Permissions (setFileExecutable)
-import              Text.Printf (printf)
 import              System.Uname (getRelease)
 import              Data.List.Split (splitOn)
 
@@ -1619,85 +1614,12 @@ chattyDownload label downloadInfo path = do
             , drLengthCheck = mtotalSize
             , drRetryPolicy = drRetryPolicyDefault
             }
-    x <- verifiedDownload dReq path chattyDownloadProgress
+    x <- verifiedDownloadWithProgress dReq path label mtotalSize
     if x
         then logStickyDone ("Downloaded " <> RIO.display label <> ".")
         else logStickyDone "Already downloaded."
   where
     mtotalSize = downloadInfoContentLength downloadInfo
-    chattyDownloadProgress _ = do
-        _ <- logSticky $ RIO.display label <> ": download has begun"
-        CL.map (Sum . S.length)
-          .| chunksOverTime 1
-          .| go
-      where
-        go = evalStateC 0 $ awaitForever $ \(Sum size) -> do
-            modify (+ size)
-            totalSoFar <- get
-            logSticky $ fromString $
-                case mtotalSize of
-                    Nothing -> chattyProgressNoTotal totalSoFar
-                    Just 0 -> chattyProgressNoTotal totalSoFar
-                    Just totalSize -> chattyProgressWithTotal totalSoFar totalSize
-
-        -- Example: ghc: 42.13 KiB downloaded...
-        chattyProgressNoTotal totalSoFar =
-            printf ("%s: " <> bytesfmt "%7.2f" totalSoFar <> " downloaded...")
-                   (T.unpack label)
-
-        -- Example: ghc: 50.00 MiB / 100.00 MiB (50.00%) downloaded...
-        chattyProgressWithTotal totalSoFar total =
-          printf ("%s: " <>
-                  bytesfmt "%7.2f" totalSoFar <> " / " <>
-                  bytesfmt "%.2f" total <>
-                  " (%6.2f%%) downloaded...")
-                 (T.unpack label)
-                 percentage
-          where percentage :: Double
-                percentage = fromIntegral totalSoFar / fromIntegral total * 100
-
--- | Given a printf format string for the decimal part and a number of
--- bytes, formats the bytes using an appropriate unit and returns the
--- formatted string.
---
--- >>> bytesfmt "%.2" 512368
--- "500.359375 KiB"
-bytesfmt :: Integral a => String -> a -> String
-bytesfmt formatter bs = printf (formatter <> " %s")
-                               (fromIntegral (signum bs) * dec :: Double)
-                               (bytesSuffixes !! i)
-  where
-    (dec,i) = getSuffix (abs bs)
-    getSuffix n = until p (\(x,y) -> (x / 1024, y+1)) (fromIntegral n,0)
-      where p (n',numDivs) = n' < 1024 || numDivs == (length bytesSuffixes - 1)
-    bytesSuffixes :: [String]
-    bytesSuffixes = ["B","KiB","MiB","GiB","TiB","PiB","EiB","ZiB","YiB"]
-
--- Await eagerly (collect with monoidal append),
--- but space out yields by at least the given amount of time.
--- The final yield may come sooner, and may be a superfluous mempty.
--- Note that Integer and Float literals can be turned into NominalDiffTime
--- (these literals are interpreted as "seconds")
-chunksOverTime :: (Monoid a, Semigroup a, MonadIO m) => NominalDiffTime -> ConduitM a a m ()
-chunksOverTime diff = do
-    currentTime <- liftIO getCurrentTime
-    evalStateC (currentTime, mempty) go
-  where
-    -- State is a tuple of:
-    -- * the last time a yield happened (or the beginning of the sink)
-    -- * the accumulated awaits since the last yield
-    go = await >>= \case
-      Nothing -> do
-        (_, acc) <- get
-        yield acc
-      Just a -> do
-        (lastTime, acc) <- get
-        let acc' = acc <> a
-        currentTime <- liftIO getCurrentTime
-        if diff < diffUTCTime currentTime lastTime
-          then put (currentTime, mempty) >> yield acc'
-          else put (lastTime,    acc')
-        go
 
 -- | Perform a basic sanity check of GHC
 sanityCheck :: (HasProcessContext env, HasLogFunc env)

stack.yaml

@@ -1,4 +1,4 @@
-resolver: snapshot.yaml
+resolver: snapshot-lts-11.yaml
 
 packages:
 - .