More error information when Haddock unpacking fails

Data/Unpacking.hs

@@ -7,6 +7,8 @@ module Data.Unpacking
     , createHoogleDatabases
     ) where
 
+import Control.Concurrent.Async
+import Data.Conduit.Process
 import Import hiding (runDB)
 import Data.BlobStore
 import Handler.Haddock
@@ -147,13 +149,22 @@ unpackRawDocsTo store ident say destdir =
 
         createTree destdir
         say "Unpacking tarball"
-        (Nothing, Nothing, Nothing, ph) <- createProcess
+        (ClosedStream, out, err, cph) <- streamingProcess (proc "tar" ["xf", tempfp])
-            (proc "tar" ["xf", tempfp])
+            { cwd = Just $ fpToString destdir
-                { cwd = Just $ fpToString destdir
+            }
-                }
+        (ec, out', err') <- liftIO $ runConcurrently $ (,,)
-        ec <- waitForProcess ph
+            <$> Concurrently (waitForStreamingProcess cph)
-        if ec == ExitSuccess then return () else throwM ec
+            <*> Concurrently (out $$ foldC)
+            <*> Concurrently (err $$ foldC)
+        unless (ec == ExitSuccess) $ throwM
+            $ HaddockBundleUnpackException ec out' err'
 
+data HaddockBundleUnpackException = HaddockBundleUnpackException
+    !ExitCode
+    !ByteString
+    !ByteString
+    deriving (Show, Typeable)
+instance Exception HaddockBundleUnpackException
 
 unpacker
     :: Dirs

Import.hs

@@ -51,6 +51,11 @@ requireDocs stackageEnt = do
                     <p>This page will automatically reload every second.
                     <p>Current status: #{msg}
             |]
-        USFailed e -> invalidArgs
+        USFailed e -> do
-            [ "Docs not available: " ++ e
+            $logWarn $ "Docs not available: " ++ tshow
-            ]
+                ( stackageSlug $ entityVal stackageEnt
+                , e
+                )
+            invalidArgs
+                [ "Docs not available: " ++ e
+                ]