From 648d69c14a31d13db21bcd51d32e25fd5c52ab4f Mon Sep 17 00:00:00 2001 From: Lucy C <12953208+elvece@users.noreply.github.com> Date: Mon, 19 Sep 2022 15:18:14 -0600 Subject: [PATCH] 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 | 1 + src/Application.hs | 2 +- src/Cli/Cli.hs | 66 ++++++++++++++++++++++++++++++++++++++------ src/Handler/Admin.hs | 16 ++++------- src/Handler/Util.hs | 3 ++ 5 files changed, 68 insertions(+), 20 deletions(-) diff --git a/.gitignore b/.gitignore index dc6cfbf..8838380 100644 --- a/.gitignore +++ b/.gitignore @@ -38,3 +38,4 @@ start9-registry.aux start9-registry.ps shell.nix testdata/ +lbuild.sh diff --git a/src/Application.hs b/src/Application.hs index 3f058d4..b0ded17 100644 --- a/src/Application.hs +++ b/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 diff --git a/src/Cli/Cli.hs b/src/Cli/Cli.hs index 861f835..615c5ef 100644 --- a/src/Cli/Cli.hs +++ b/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) diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 27a2c5b..038e7f7 100644 --- a/src/Handler/Admin.hs +++ b/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 ( - PkgId (unPkgId), - ) +import Lib.Types.Core (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 - _ <- runDB $ upsert (EosHash version hash) [EosHashHash =. hash] + runConduit $ rawRequestBody .| ungzip .| sinkFile path + void . runDB $ upsert (EosHash version hash) [EosHashHash =. hash] let targetPath = root show version removePathForcibly targetPath createDirectoryIfMissing True targetPath diff --git a/src/Handler/Util.hs b/src/Handler/Util.hs index 4c41cb7..949e94a 100644 --- a/src/Handler/Util.hs +++ b/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"