diff --git a/Data/Unpacking.hs b/Data/Unpacking.hs index d505720..309da3f 100644 --- a/Data/Unpacking.hs +++ b/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 - (proc "tar" ["xf", tempfp]) - { cwd = Just $ fpToString destdir - } - ec <- waitForProcess ph - if ec == ExitSuccess then return () else throwM ec + (ClosedStream, out, err, cph) <- streamingProcess (proc "tar" ["xf", tempfp]) + { cwd = Just $ fpToString destdir + } + (ec, out', err') <- liftIO $ runConcurrently $ (,,) + <$> Concurrently (waitForStreamingProcess cph) + <*> 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 diff --git a/Import.hs b/Import.hs index 63fd9d1..188bf25 100644 --- a/Import.hs +++ b/Import.hs @@ -51,6 +51,11 @@ requireDocs stackageEnt = do

This page will automatically reload every second.

Current status: #{msg} |] - USFailed e -> invalidArgs - [ "Docs not available: " ++ e - ] + USFailed e -> do + $logWarn $ "Docs not available: " ++ tshow + ( stackageSlug $ entityVal stackageEnt + , e + ) + invalidArgs + [ "Docs not available: " ++ e + ]