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

.gitignore

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

src/Application.hs

@@ -378,7 +378,7 @@ makeAuthWare _ app req res = next
 -- | Warp settings for the given foundation value.
 warpSettings :: AppPort -> RegistryCtx -> Settings
 warpSettings port foundation =
-    setTimeout 60 $
+    setTimeout 90 $
         setPort (fromIntegral port) $
             setHost (appHost $ appSettings foundation) $
                 setOnException

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 (
+import Lib.Types.Core (PkgId (..))
-    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) ())
+    let compressedFilePath = "/tmp/eos.img.gz"
-    body <- observedStreamFile (updateProgress bar . const . sfs2prog) img
+    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)

src/Handler/Admin.hs

@@ -10,6 +10,7 @@ import Conduit (
     sinkFile,
     (.|),
  )
+import Control.Monad.Extra
 import Control.Monad.Reader.Has (ask)
 import Control.Monad.Trans.Maybe (MaybeT (..))
 import Data.Aeson (
@@ -22,6 +23,7 @@ import Data.Aeson (
     (.:?),
     (.=),
  )
+import Data.Conduit.Zlib (ungzip)
 import Data.HashMap.Internal.Strict (
     HashMap,
     differenceWith,
@@ -35,6 +37,7 @@ import Data.List (
 import Data.String.Interpolate.IsString (
     i,
  )
+import Data.Time
 import Database.Persist (
     Entity (entityKey),
     PersistStoreRead (get),
@@ -64,9 +67,7 @@ import Lib.PkgRepository (
     getPackages,
     getVersionsFor,
  )
-import Lib.Types.Core (
+import Lib.Types.Core (PkgId (unPkgId))
-    PkgId (unPkgId),
- )
 import Lib.Types.Emver (Version (..))
 import Lib.Types.Manifest (PackageManifest (..))
 import Model (
@@ -93,14 +94,11 @@ import Startlude (
     Eq,
     Int,
     Maybe (..),
-    Monad ((>>=)),
     Show,
     SomeException (..),
     Text,
     asum,
-    fmap,
     fromMaybe,
-    getCurrentTime,
     guarded,
     hush,
     isNothing,
@@ -110,8 +108,6 @@ import Startlude (
     show,
     toS,
     traverse,
-    void,
-    when,
     zip,
     ($),
     (&&&),
@@ -197,8 +193,8 @@ postEosUploadR = do
     createDirectoryIfMissing True resourcesTemp
     withTempDirectory resourcesTemp "neweos" $ \dir -> do
         let path = dir </> "eos" <.> "img"
-        runConduit $ rawRequestBody .| sinkFile path
+        runConduit $ rawRequestBody .| ungzip .| sinkFile path
-        _ <- runDB $ upsert (EosHash version hash) [EosHashHash =. hash]
+        void . runDB $ upsert (EosHash version hash) [EosHashHash =. hash]
         let targetPath = root </> show version
         removePathForcibly targetPath
         createDirectoryIfMissing True targetPath

src/Handler/Util.hs

@@ -97,6 +97,7 @@ getVersionSpecFromQuery = do
         Nothing -> sendResponseStatus status400 ("Invalid App Version Specification" :: Text)
         Just t -> pure t
 
+
 getVersionFromQuery :: MonadHandler m => m (Maybe Version)
 getVersionFromQuery = do
     versionString <- lookupGetParam "version"
@@ -106,9 +107,11 @@ getVersionFromQuery = do
             Nothing -> sendResponseStatus status400 ("Invalid Version" :: Text)
             Just t -> pure (Just t)
 
+
 getHashFromQuery :: MonadHandler m => m (Maybe Text)
 getHashFromQuery = lookupGetParam "hash"
 
+
 versionPriorityFromQueryIsMin :: MonadHandler m => m Bool
 versionPriorityFromQueryIsMin = do
     priorityString <- lookupGetParam "version-priority"