Provide own lzma conduit adapters

3 files changed, 38 insertions, 4 deletions

diff --git a/lib/SlackBuilder/Download.hs b/lib/SlackBuilder/Download.hs
index 088f2cc..cf8b496 100644
--- a/lib/SlackBuilder/Download.hs
+++ b/lib/SlackBuilder/Download.hs
@@ -18,11 +18,13 @@ module SlackBuilder.Download
     , uploadSource
     ) where
 
+import qualified Codec.Compression.Lzma as Lzma
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as ByteString
 import qualified Data.ByteString.Char8 as Char8
 import Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.List.NonEmpty as NonEmpty
+import Data.NonNull (toNullable)
 import Data.Foldable (find)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
@@ -73,11 +75,11 @@ import Conduit
     , ZipSink(..)
     , await
     , sourceFile
+    , leftover, awaitNonNull
     )
 import Data.Conduit.Tar (FileInfo(..), tarFilePath, untar)
 import Crypto.Hash (Digest, MD5, hashInit, hashFinalize, hashUpdate)
 import Data.Void (Void)
-import qualified Data.Conduit.Lzma as Lzma
 import qualified Data.Conduit.Zlib as Zlib
 import Control.Monad.Catch (MonadThrow(..))
 import Data.Maybe (fromMaybe)
@@ -191,7 +193,7 @@ cloneAndArchive repo tarballPath tagPrefix = do
 createLzmaTarball :: FilePath -> FilePath -> IO (Digest MD5)
 createLzmaTarball input output = runConduitRes $ yield input
     .| void tarFilePath
-    .| Lzma.compress Nothing
+    .| compressLzma
     .| sinkFileAndHash output
 
 responseBodySource :: MonadIO m => Response BodyReader -> ConduitT i ByteString m ()
@@ -272,6 +274,37 @@ sinkFileAndHash :: MonadResource m => FilePath -> ConduitT ByteString Void m (Di
 sinkFileAndHash target = getZipSink
     $ ZipSink (sinkFile target) *> ZipSink sinkHash
 
+compressLzma :: MonadIO m => ConduitT ByteString ByteString m ()
+compressLzma = liftIO (Lzma.compressIO Lzma.defaultCompressParams) >>= go
+  where
+    go (Lzma.CompressInputRequired flush supplyInput) = do
+        next <- await
+        result <- case next of
+            Just input
+                | ByteString.null input -> liftIO flush
+                | otherwise -> liftIO $ supplyInput input
+            Nothing -> liftIO $ supplyInput mempty
+        go result
+    go (Lzma.CompressOutputAvailable output stream) = yield output
+        >> liftIO stream >>= go
+    go Lzma.CompressStreamEnd = pure ()
+
+decompressLzma :: (MonadThrow m, MonadIO m) => ConduitT ByteString ByteString m ()
+decompressLzma = liftIO (Lzma.decompressIO Lzma.defaultDecompressParams) >>= go
+  where
+    go (Lzma.DecompressInputRequired processor) = do
+        next <- awaitNonNull
+        result <- case next of
+            Just input -> liftIO $ processor (toNullable input)
+            Nothing -> liftIO $ processor mempty
+        go result
+    go (Lzma.DecompressOutputAvailable output stream) = yield output
+        >> liftIO stream
+        >>= go
+    go (Lzma.DecompressStreamEnd output) = leftover output
+    go (Lzma.DecompressStreamError lzmaReturn) = throwM
+        $ LzmaDecompressionFailed lzmaReturn
+
 -- | Downloads a compressed tar archive and extracts its contents on the fly to
 -- a directory.
 --
@@ -293,7 +326,7 @@ extractRemote uri' packagePath =
                         | Just directoryName' <- stripExtension ".tar.gz" attachmentName' ->
                             (Zlib.ungzip, Just directoryName')
                         | Just directoryName' <- stripExtension ".tar.xz" attachmentName' ->
-                            (Lzma.decompress Nothing, Just directoryName')
+                            (decompressLzma, Just directoryName')
                     _ -> (pure (), Nothing)
         runConduitRes $ responseBodySource response
             .| decompress
diff --git a/lib/SlackBuilder/LatestVersionCheck.hs b/lib/SlackBuilder/LatestVersionCheck.hs
index ad8d6b8..a1e8abc 100644
--- a/lib/SlackBuilder/LatestVersionCheck.hs
+++ b/lib/SlackBuilder/LatestVersionCheck.hs
@@ -46,7 +46,6 @@ import qualified Data.Aeson.KeyMap as KeyMap
 import GHC.Records (HasField(..))
 import Control.Monad.Trans.Reader (asks)
 import Control.Monad.IO.Class (MonadIO(..))
-import Control.Applicative (Applicative(liftA2))
 import Data.Char (isAlpha)
 
 data PackageOwner = PackageOwner
diff --git a/lib/SlackBuilder/Trans.hs b/lib/SlackBuilder/Trans.hs
index 8d1d5b6..3ab162c 100644
--- a/lib/SlackBuilder/Trans.hs
+++ b/lib/SlackBuilder/Trans.hs
@@ -17,10 +17,12 @@ import Control.Monad.Catch (MonadCatch(..), MonadThrow(..))
 import Control.Exception (Exception(..))
 import System.FilePath ((</>))
 import Text.URI (URI)
+import qualified Codec.Compression.Lzma as Lzma
 
 data SlackBuilderException
     = UpdaterNotFound Text
     | HttpsUrlExpected URI
+    | LzmaDecompressionFailed Lzma.LzmaRet
     deriving Show
 
 instance Exception SlackBuilderException