Debug logging when stack is downloading

commercialhaskell · May 4, 2016 · db52f16 · db52f16
1 parent 9be58d7
commit db52f16
Show file tree

Hide file tree

Showing 2 changed files with 53 additions and 40 deletions.
diff --git a/src/Network/HTTP/Download.hs b/src/Network/HTTP/Download.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE DeriveDataTypeable    #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE TemplateHaskell  #-}
 module Network.HTTP.Download
     ( verifiedDownload
     , DownloadRequest(..)
@@ -28,6 +29,7 @@ import           Control.Exception.Enclosed  (handleIO)
 import           Control.Monad               (void)
 import           Control.Monad.Catch         (MonadThrow, MonadMask, throwM)
 import           Control.Monad.IO.Class      (MonadIO, liftIO)
+import           Control.Monad.Logger        (MonadLogger, logDebug)
 import           Control.Monad.Reader        (MonadReader, ReaderT, ask,
                                               runReaderT)
 import           Data.Aeson.Extended         (FromJSON, parseJSON)
@@ -40,7 +42,11 @@ import           Data.Conduit.Attoparsec     (sinkParser)
 import           Data.Conduit.Binary         (sinkHandle, sourceHandle)
 import qualified Data.Conduit.Binary         as CB
 import           Data.Foldable               (forM_)
+import           Data.Monoid                 ((<>))
+import           Data.Text.Encoding.Error    (lenientDecode)
+import           Data.Text.Encoding          (decodeUtf8With)
 import           Data.Typeable               (Typeable)
+import           Network.HTTP.Client         (path)
 import           Network.HTTP.Client.Conduit (HasHttpManager, Manager, Request,
                                               Response, checkStatus,
                                               getHttpManager, parseUrl,
@@ -64,7 +70,7 @@ import           System.IO                   (IOMode (ReadMode),
 -- appropriate destination.
 --
 -- Throws an exception if things go wrong
-download :: (MonadReader env m, HasHttpManager env, MonadIO m)
+download :: (MonadReader env m, HasHttpManager env, MonadIO m, MonadLogger m)
          => Request
          -> Path Abs File -- ^ destination
          -> m Bool -- ^ Was a downloaded performed (True) or did the file already exist (False)?
@@ -81,11 +87,12 @@ download req destpath = do
 -- | Same as 'download', but will download a file a second time if it is already present.
 --
 -- Returns 'True' if the file was downloaded, 'False' otherwise
-redownload :: (MonadReader env m, HasHttpManager env, MonadIO m)
+redownload :: (MonadReader env m, HasHttpManager env, MonadIO m, MonadLogger m)
            => Request
            -> Path Abs File -- ^ destination
            -> m Bool
 redownload req0 dest = do
+    $logDebug $ "Downloading " <> decodeUtf8With lenientDecode (path req0)
     let destFilePath = toFilePath dest
         etagFilePath = destFilePath <.> "etag"
 

diff --git a/src/Network/HTTP/Download/Verified.hs b/src/Network/HTTP/Download/Verified.hs
@@ -8,6 +8,7 @@
 {-# LANGUAGE RankNTypes            #-}
 {-# LANGUAGE GADTs                 #-}
 {-# LANGUAGE StandaloneDeriving    #-}
+{-# LANGUAGE TemplateHaskell       #-}
 module Network.HTTP.Download.Verified
   ( verifiedDownload
   , recoveringHttp
@@ -19,38 +20,41 @@ module Network.HTTP.Download.Verified
   , VerifiedDownloadException(..)
   ) where
 
-import qualified Data.List as List
-import qualified Data.ByteString as ByteString
-import qualified Data.ByteString.Base64 as B64
-import qualified Data.Conduit.Binary as CB
-import qualified Data.Conduit.List as CL
-import qualified Data.Text as Text
-import qualified Data.Text.Encoding as Text
+import qualified    Data.List as List
+import qualified    Data.ByteString as ByteString
+import qualified    Data.ByteString.Base64 as B64
+import qualified    Data.Conduit.Binary as CB
+import qualified    Data.Conduit.List as CL
+import qualified    Data.Text as Text
+import qualified    Data.Text.Encoding as Text
 
-import Control.Monad
-import Control.Monad.Catch
-import Control.Monad.IO.Class
-import Control.Monad.Reader
-import Control.Retry (recovering,limitRetries,RetryPolicy,constantDelay)
-import Control.Applicative
+import              Control.Applicative
+import              Control.Monad
+import              Control.Monad.Catch
+import              Control.Monad.IO.Class
+import              Control.Monad.Logger (logDebug, MonadLogger)
+import              Control.Monad.Reader
+import              Control.Retry (recovering,limitRetries,RetryPolicy,constantDelay)
 import "cryptohash" Crypto.Hash
-import Crypto.Hash.Conduit (sinkHash)
-import Data.ByteString (ByteString)
-import Data.ByteString.Char8 (readInteger)
-import Data.Conduit
-import Data.Conduit.Binary (sourceHandle, sinkHandle)
-import Data.Foldable (traverse_,for_)
-import Data.Monoid
-import Data.String
-import Data.Typeable (Typeable)
-import GHC.IO.Exception (IOException(..),IOErrorType(..))
-import Network.HTTP.Client.Conduit
-import Network.HTTP.Types.Header (hContentLength, hContentMD5)
-import Path
-import Prelude -- Fix AMP warning
-import System.FilePath((<.>))
-import System.Directory
-import System.IO
+import              Crypto.Hash.Conduit (sinkHash)
+import              Data.ByteString (ByteString)
+import              Data.ByteString.Char8 (readInteger)
+import              Data.Conduit
+import              Data.Conduit.Binary (sourceHandle, sinkHandle)
+import              Data.Foldable (traverse_,for_)
+import              Data.Monoid
+import              Data.String
+import              Data.Text.Encoding (decodeUtf8With)
+import              Data.Text.Encoding.Error (lenientDecode)
+import              Data.Typeable (Typeable)
+import              GHC.IO.Exception (IOException(..),IOErrorType(..))
+import              Network.HTTP.Client.Conduit
+import              Network.HTTP.Types.Header (hContentLength, hContentMD5)
+import              Path
+import              Prelude -- Fix AMP warning
+import              System.Directory
+import              System.FilePath ((<.>))
+import              System.IO
 
 -- | A request together with some checks to perform.
 data DownloadRequest = DownloadRequest
@@ -215,21 +219,23 @@ recoveringHttp retryPolicy =
 -- Throws VerifiedDownloadException.
 -- Throws IOExceptions related to file system operations.
 -- Throws HttpException.
-verifiedDownload :: (MonadReader env m, HasHttpManager env, MonadIO m)
+verifiedDownload :: (MonadReader env m, HasHttpManager env, MonadIO m, MonadLogger m)
          => DownloadRequest
          -> Path Abs File -- ^ destination
          -> (Maybe Integer -> Sink ByteString (ReaderT env IO) ()) -- ^ custom hook to observe progress
          -> m Bool -- ^ Whether a download was performed
 verifiedDownload DownloadRequest{..} destpath progressSink = do
     let req = drRequest
     env <- ask
-    liftIO $ whenM' getShouldDownload $ do
-        createDirectoryIfMissing True dir
-        withBinaryFile fptmp WriteMode $ \h ->
-            recoveringHttp drRetryPolicy $
-                flip runReaderT env $
-                    withResponse req (go h)
-        renameFile fptmp fp
+    whenM' (liftIO getShouldDownload) $ do
+        $logDebug $ "Downloading " <> decodeUtf8With lenientDecode (path req)
+        liftIO $ do
+            createDirectoryIfMissing True dir
+            withBinaryFile fptmp WriteMode $ \h ->
+                recoveringHttp drRetryPolicy $
+                    flip runReaderT env $
+                        withResponse req (go h)
+            renameFile fptmp fp
   where
     whenM' mp m = do
         p <- mp