refactor upload with zimple gzip approach - progress bar broken

.gitignore

@@ -38,3 +38,4 @@ start9-registry.aux
 start9-registry.ps
 shell.nix
 testdata/
+lbuild.sh

src/Cli/Cli.hs

@@ -17,12 +17,11 @@ import Codec.Archive.Zip.Conduit.Zip (ZipOptions (..), zipFileData, zipStream)
 import Conduit (
     ConduitT,
     MonadResource,
-    awaitForever,
     foldC,
     runConduit,
     runResourceT,
-    sinkHandle,
+    sinkFileCautious,
-    sinkNull,
+    sourceFile,
     yield,
     (.|),
  )
@@ -50,6 +49,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 (
@@ -64,6 +64,7 @@ import Data.String.Interpolate.IsString (
     i,
  )
 import Data.Text (toLower)
+import Data.Text qualified as T
 import Data.Time (getTimeZone, utcToLocalTime)
 import Dhall (
     Encoder (embed),
@@ -98,6 +99,7 @@ import Network.HTTP.Simple (
     httpLBS,
     parseRequest,
     setRequestBody,
+    setRequestBodyFile,
     setRequestBodyJSON,
     setRequestBodySource,
     setRequestHeaders,
@@ -186,7 +188,6 @@ import Startlude (
     panic,
     show,
     snd,
-    stdout,
     unlessM,
     void,
     when,
@@ -205,10 +206,12 @@ import System.Directory (
     getFileSize,
     getHomeDirectory,
     listDirectory,
+    removeFile,
  )
 import System.FilePath (
     takeDirectory,
     takeExtension,
+    (<.>),
     (</>),
  )
 import System.ProgressBar (
@@ -590,28 +593,40 @@ upload (Upload name mpkg shouldIndex) = do
         sfs2prog StreamFileStatus{..} = Progress (fromIntegral readSoFar) (fromIntegral fileSize) ()
 
 
+-- stream read file
+-- stream zip file
+-- stream zip into request body
+-- store on server uncomressed?
 eosUpload :: EosUpload -> IO ()
 eosUpload (EosUpload name img version) = do
     PublishCfgRepo{..} <- findNameInCfg name
-    size <- getFileSize img
     noBody <-
         parseRequest ("POST " <> show publishCfgRepoLocation <> "/admin/v0/eos-upload")
             <&> setRequestHeaders [("accept", "text/plain")]
+            <&> setRequestHeaders [("Content-Type", "application/octet-stream")]
             <&> setRequestHeaders [("Content-Encoding", "gzip")]
             <&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass)
     hash <- hashFile @_ @SHA256 img
-    bar <- newProgressBar defStyle 30 (Progress 0 (fromIntegral size) ())
+    -- let z = (createZipEntry img (Just $ fromIntegral size) .| (zipStream zipOptions))
-    body <- observedStreamFile (updateProgress bar . const . sfs2prog) img
+    let compressedFilePath = img <.> "gz"
-    let r = liftIO $ runResourceT $ runConduit $ (createZipEntry img (Just $ fromIntegral size) .| void (zipStream zipOptions)) .| sinkHandle stdout
+    runResourceT $
-
+        runConduit $
+            sourceFile img
+                .| gzip
+                .| sinkFileCautious compressedFilePath
+    gSize <- getFileSize compressedFilePath
+    bar <- newProgressBar defStyle 30 (Progress 0 (fromIntegral gSize) ())
+    body <- observedStreamFile (updateProgress bar . const . sfs2prog) $ compressedFilePath
     let withBody = setRequestBody body noBody
     let withQParams =
             setRequestQueryString
                 [("version", Just $ show version), ("hash", Just $ convertToBase Base16 hash)]
                 withBody
-    let withSource = setRequestBodySource (fromIntegral size) (r) withQParams
+    -- let withSource = setRequestBodySource (fromIntegral size) _ withQParams
+    let req = setRequestBodyFile compressedFilePath withQParams
     manager <- newTlsManager
-    res <- runReaderT (httpLbs withSource) manager
+    res <- runReaderT (httpLbs req) manager
+    removeFile $ compressedFilePath
     if getResponseStatus res == status200
         then -- no output is successful
             pure ()
@@ -625,13 +640,14 @@ eosUpload (EosUpload name img version) = do
         zipOptions =
             ZipOptions
                 { zipOpt64 = True
-                , zipOptCompressLevel = 0
+                , zipOptCompressLevel = 6
                 , zipOptInfo = ZipInfo{zipComment = encodeUtf8 "zipped eos image"}
                 }
         createZipEntry ::
             MonadResource m =>
             FilePath ->
             Maybe Word64 ->
+            -- ZipData m ->
             ConduitT () (ZipEntry, ZipData m) m ()
         createZipEntry path size = do
             let d = zipFileData img
@@ -639,7 +655,7 @@ eosUpload (EosUpload name img version) = do
             localTimeZone <- liftIO $ getTimeZone utcTime
             let zipEntry =
                     ZipEntry
-                        { zipEntryName = Right $ encodeUtf8 $ show path
+                        { zipEntryName = Left $ T.pack "eos.img.gz"
                         , zipEntryTime = utcToLocalTime localTimeZone utcTime
                         , zipEntrySize = size
                         , zipEntryExternalAttributes = Nothing
@@ -647,11 +663,6 @@ eosUpload (EosUpload name img version) = do
             yield (zipEntry, d)
 
 
-_yieldFinal :: Monad m => ConduitT (ZipEntry, ZipData m) B8.ByteString m Word64 -> ConduitT () B8.ByteString m ()
-_yieldFinal consumer = awaitForever $ \_ -> do
-    yield consumer .| sinkNull
-
-
 index :: String -> String -> Version -> IO ()
 index name pkg v = performHttp name "POST" [i|/admin/v0/index|] (IndexPkgReq (PkgId $ toS pkg) v)
 

src/Handler/Admin.hs

@@ -5,27 +5,9 @@
 
 module Handler.Admin where
 
-import Codec.Archive.Zip.Conduit.Zip (
-    ZipData (ZipDataSource),
-    ZipEntry (
-        ZipEntry,
-        zipEntryExternalAttributes,
-        zipEntryName,
-        zipEntrySize,
-        zipEntryTime
-    ),
-    ZipInfo (..),
-    ZipOptions (..),
-    zipStream,
- )
 import Conduit (
-    ConduitT,
-    MonadUnliftIO,
-    fuseUpstream,
     runConduit,
     sinkFile,
-    sinkFileBS,
-    yield,
     (.|),
  )
 import Control.Monad.Extra
@@ -41,7 +23,6 @@ import Data.Aeson (
     (.:?),
     (.=),
  )
-import Data.ByteString (ByteString)
 import Data.HashMap.Internal.Strict (
     HashMap,
     differenceWith,
@@ -109,25 +90,19 @@ import Settings
 import Startlude (
     Applicative (pure),
     Bool (..),
-    Either (Right),
     Eq,
-    FilePath,
     Int,
     Maybe (..),
     Show,
     SomeException (..),
     Text,
-    Word64,
     asum,
-    decodeUtf8,
-    encodeUtf8,
     fromMaybe,
     guarded,
     hush,
     isNothing,
     liftIO,
     not,
-    readMaybe,
     replicate,
     show,
     toS,
@@ -160,7 +135,6 @@ import Yesod (
     delete,
     getsYesod,
     logError,
-    lookupHeader,
     rawRequestBody,
     requireCheckJsonBody,
     runDB,
@@ -214,42 +188,16 @@ postEosUploadR = do
     hash <- case maybeHash of
         Nothing -> sendResponseStatus status400 ("Missing Hash" :: Text)
         Just h -> pure h
-    -- (maybeSize :: Maybe Word64) <- maybeM (pure Nothing) (pure . readMaybe . decodeUtf8) (lookupHeader "Content-Length")
     resourcesTemp <- getsYesod $ (</> "temp") . resourcesDir . appSettings
     createDirectoryIfMissing True resourcesTemp
     withTempDirectory resourcesTemp "neweos" $ \dir -> do
         let path = dir </> "eos" <.> "img"
         runConduit $ rawRequestBody .| sinkFile path
-        -- void . runConduit $ createZipEntry path maybeSize rawRequestBody .| (zipStream zipOptions `fuseUpstream` sinkFileBS path)
         void . runDB $ upsert (EosHash version hash) [EosHashHash =. hash]
         let targetPath = root </> show version
         removePathForcibly targetPath
         createDirectoryIfMissing True targetPath
         renameDirectory dir targetPath
-    where
-        zipOptions =
-            ZipOptions
-                { zipOpt64 = True
-                , zipOptCompressLevel = -1
-                , zipOptInfo = ZipInfo{zipComment = encodeUtf8 "zipped eos image"}
-                }
-        createZipEntry ::
-            (MonadUnliftIO m) =>
-            FilePath ->
-            Maybe Word64 ->
-            ConduitT () ByteString m () ->
-            ConduitT () (ZipEntry, ZipData m) m ()
-        createZipEntry path size dataSource = do
-            utcTime <- liftIO getCurrentTime
-            localTimeZone <- liftIO $ getTimeZone utcTime
-            let zipEntry =
-                    ZipEntry
-                        { zipEntryName = Right $ encodeUtf8 $ show path
-                        , zipEntryTime = utcToLocalTime localTimeZone utcTime
-                        , zipEntrySize = size
-                        , zipEntryExternalAttributes = Nothing
-                        }
-            yield (zipEntry, ZipDataSource dataSource)
 
 
 data IndexPkgReq = IndexPkgReq