Feature/zip upload (#124)

* zip eos image on upload

* fix warning

* revert content length as its already set by module

* move stream zipping to cli upload

* refactor upload with simple gzip approach - progress bar broken

* increase timeout

* fix request body and unzip once uploaded

* unzipped in wrong fn; cleanup

* add progress bar for hashing and zipping, cleanup files

* add messaging to progress bars

src/Cli/Cli.hs

@@ -13,8 +13,15 @@ module Cli.Cli (
 ) where
 
 import Conduit (
+    ConduitT,
+    MonadIO,
+    awaitForever,
     foldC,
     runConduit,
+    runConduitRes,
+    sinkFileCautious,
+    sourceFile,
+    yield,
     (.|),
  )
 import Control.Monad.Logger (
@@ -29,6 +36,7 @@ import Crypto.Hash (
     SHA256 (SHA256),
     hashWith,
  )
+import Crypto.Hash.Conduit (hashFile, sinkHash)
 import Data.Aeson (
     ToJSON,
     eitherDecodeStrict,
@@ -40,6 +48,7 @@ import Data.ByteArray.Encoding (
 import Data.ByteString.Char8 qualified as B8
 import Data.ByteString.Lazy qualified as LB
 import Data.Conduit.Process (readProcess)
+import Data.Conduit.Zlib (gzip)
 import Data.Default
 import Data.Functor.Contravariant (contramap)
 import Data.HashMap.Internal.Strict (
@@ -70,9 +79,7 @@ import Handler.Admin (
     PackageList (..),
  )
 import Lib.External.AppMgr (sourceManifest)
-import Lib.Types.Core (
-    PkgId (..),
- )
+import Lib.Types.Core (PkgId (..))
 import Lib.Types.Emver (Version (..))
 import Lib.Types.Manifest (PackageManifest (..))
 import Network.HTTP.Client.Conduit (
@@ -82,6 +89,7 @@ import Network.HTTP.Client.Conduit (
     observedStreamFile,
  )
 import Network.HTTP.Client.TLS (newTlsManager)
+import Network.HTTP.Conduit (responseTimeoutMicro)
 import Network.HTTP.Simple (
     getResponseBody,
     getResponseStatus,
@@ -90,7 +98,9 @@ import Network.HTTP.Simple (
     parseRequest,
     setRequestBody,
     setRequestBodyJSON,
-    setRequestHeaders, setRequestQueryString
+    setRequestHeaders,
+    setRequestQueryString,
+    setRequestResponseTimeout,
  )
 import Network.HTTP.Types (status200)
 import Network.URI (
@@ -153,6 +163,7 @@ import Startlude (
     ReaderT (runReaderT),
     Semigroup ((<>)),
     Show,
+    SomeException,
     String,
     appendFile,
     const,
@@ -167,10 +178,12 @@ import Startlude (
     fromMaybe,
     fst,
     headMay,
+    liftIO,
     not,
     panic,
     show,
     snd,
+    throwIO,
     unlessM,
     void,
     when,
@@ -189,6 +202,7 @@ import System.Directory (
     getFileSize,
     getHomeDirectory,
     listDirectory,
+    removeFile,
  )
 import System.FilePath (
     takeDirectory,
@@ -197,15 +211,19 @@ import System.FilePath (
  )
 import System.ProgressBar (
     Progress (..),
+    ProgressBar,
+    Style (stylePrefix),
     defStyle,
+    incProgress,
+    msg,
     newProgressBar,
     updateProgress,
  )
+import UnliftIO.Exception (handle)
 import Yesod (
     logError,
     logWarn,
  )
-import Crypto.Hash.Conduit (hashFile)
 
 
 data Upload = Upload
@@ -215,6 +233,7 @@ data Upload = Upload
     }
     deriving (Show)
 
+
 data EosUpload = EosUpload
     { eosRepoName :: !String
     , eosPath :: !FilePath
@@ -429,6 +448,7 @@ parsePkgCat = subparser $ command "categorize" (info cat $ progDesc "Add or remo
                     <*> strArgument (metavar "PACKAGE_ID")
                     <*> strArgument (metavar "CATEGORY")
 
+
 parseEosPublish :: Parser EosUpload
 parseEosPublish =
     subparser $
@@ -543,6 +563,7 @@ upload (Upload name mpkg shouldIndex) = do
     noBody <-
         parseRequest ("POST " <> show publishCfgRepoLocation <> "/admin/v0/upload")
             <&> setRequestHeaders [("accept", "text/plain")]
+            <&> setRequestResponseTimeout (responseTimeoutMicro (90_000_000)) -- 90 seconds
             <&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass)
     size <- getFileSize pkg
     bar <- newProgressBar defStyle 30 (Progress 0 (fromIntegral size) ())
@@ -572,21 +593,38 @@ upload (Upload name mpkg shouldIndex) = do
         sfs2prog :: StreamFileStatus -> Progress ()
         sfs2prog StreamFileStatus{..} = Progress (fromIntegral readSoFar) (fromIntegral fileSize) ()
 
+
 eosUpload :: EosUpload -> IO ()
-eosUpload (EosUpload name img version) = do
+eosUpload (EosUpload name img version) = handle @_ @SomeException cleanup $ do
     PublishCfgRepo{..} <- findNameInCfg name
     noBody <-
         parseRequest ("POST " <> show publishCfgRepoLocation <> "/admin/v0/eos-upload")
             <&> setRequestHeaders [("accept", "text/plain")]
+            <&> setRequestResponseTimeout (responseTimeoutMicro (90_000_000)) -- 90 seconds
+            <&> setRequestHeaders [("Content-Encoding", "gzip")]
             <&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass)
     size <- getFileSize img
+    hashBar <- newProgressBar defStyle{stylePrefix = msg "Hashing"} 30 (Progress 0 (fromIntegral size) ())
+    runConduitRes $ sourceFile img .| transByteCounter hashBar .| sinkHash @_ @SHA256
     hash <- hashFile @_ @SHA256 img
-    bar <- newProgressBar defStyle 30 (Progress 0 (fromIntegral size) ())
-    body <- observedStreamFile (updateProgress bar . const . sfs2prog) img
+    let compressedFilePath = "/tmp/eos.img.gz"
+    zipBar <- newProgressBar defStyle{stylePrefix = msg "Gzipping"} 30 (Progress 0 (fromIntegral size) ())
+    runConduitRes $
+        sourceFile img
+            .| transByteCounter zipBar
+            .| gzip
+            .| sinkFileCautious compressedFilePath
+    compressedSize <- getFileSize compressedFilePath
+    fileBar <- newProgressBar defStyle{stylePrefix = msg "Uploading"} 30 (Progress 0 (fromIntegral compressedSize) ())
+    body <- observedStreamFile (updateProgress fileBar . const . sfs2prog) $ compressedFilePath
     let withBody = setRequestBody body noBody
-    let withQParams = setRequestQueryString [("version", Just $ show version), ("hash", Just $ convertToBase Base16 hash)] withBody
+    let withQParams =
+            setRequestQueryString
+                [("version", Just $ show version), ("hash", Just $ convertToBase Base16 hash)]
+                withBody
     manager <- newTlsManager
     res <- runReaderT (httpLbs withQParams) manager
+    removeFile compressedFilePath
     if getResponseStatus res == status200
         then -- no output is successful
             pure ()
@@ -597,6 +635,16 @@ eosUpload (EosUpload name img version) = do
     where
         sfs2prog :: StreamFileStatus -> Progress ()
         sfs2prog StreamFileStatus{..} = Progress (fromIntegral readSoFar) (fromIntegral fileSize) ()
+        transByteCounter :: MonadIO m => ProgressBar a -> ConduitT B8.ByteString B8.ByteString m ()
+        transByteCounter bar = awaitForever $ \bs -> do
+            let len = B8.length bs
+            liftIO $ incProgress bar len
+            yield bs
+        cleanup e = do
+            $logError $ show e
+            removeFile "/tmp/eos.img.gz"
+            throwIO e
+
 
 index :: String -> String -> Version -> IO ()
 index name pkg v = performHttp name "POST" [i|/admin/v0/index|] (IndexPkgReq (PkgId $ toS pkg) v)