From c27f68387e4afb5142ecd259e1e647de058dd29c Mon Sep 17 00:00:00 2001 From: Lucy Cifferello <12953208+elvece@users.noreply.github.com> Date: Wed, 14 Sep 2022 17:26:46 -0600 Subject: [PATCH] add progress bar for hashing and zipping, cleanup files --- src/Application.hs | 2 +- src/Cli/Cli.hs | 91 ++++++++++++++++++---------------------------- 2 files changed, 37 insertions(+), 56 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index 09fa363..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 120 $ + setTimeout 90 $ setPort (fromIntegral port) $ setHost (appHost $ appSettings foundation) $ setOnException diff --git a/src/Cli/Cli.hs b/src/Cli/Cli.hs index 12d5e14..37e72e7 100644 --- a/src/Cli/Cli.hs +++ b/src/Cli/Cli.hs @@ -12,14 +12,13 @@ module Cli.Cli ( cliMain, ) where -import Codec.Archive.Zip.Conduit.Types -import Codec.Archive.Zip.Conduit.Zip (ZipOptions (..), zipFileData, zipStream) import Conduit ( ConduitT, - MonadResource, + MonadIO, + awaitForever, foldC, runConduit, - runResourceT, + runConduitRes, sinkFileCautious, sourceFile, yield, @@ -37,7 +36,7 @@ import Crypto.Hash ( SHA256 (SHA256), hashWith, ) -import Crypto.Hash.Conduit (hashFile) +import Crypto.Hash.Conduit (hashFile, sinkHash) import Data.Aeson ( ToJSON, eitherDecodeStrict, @@ -64,8 +63,6 @@ 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), FromDhall (..), @@ -92,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, @@ -99,11 +97,10 @@ import Network.HTTP.Simple ( httpLBS, parseRequest, setRequestBody, - setRequestBodyFile, setRequestBodyJSON, - setRequestBodySource, setRequestHeaders, setRequestQueryString, + setRequestResponseTimeout, ) import Network.HTTP.Types (status200) import Network.URI ( @@ -166,12 +163,11 @@ import Startlude ( ReaderT (runReaderT), Semigroup ((<>)), Show, + SomeException (SomeException), String, - Word64, appendFile, const, decodeUtf8, - encodeUtf8, exitWith, filter, flip, @@ -181,13 +177,13 @@ import Startlude ( fromIntegral, fromMaybe, fst, - getCurrentTime, headMay, liftIO, not, panic, show, snd, + throwIO, unlessM, void, when, @@ -211,15 +207,17 @@ import System.Directory ( import System.FilePath ( takeDirectory, takeExtension, - (<.>), (), ) import System.ProgressBar ( Progress (..), + ProgressBar, defStyle, + incProgress, newProgressBar, updateProgress, ) +import UnliftIO.Exception (handle) import Yesod ( logError, logWarn, @@ -563,6 +561,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) ()) @@ -593,40 +592,37 @@ 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? --- nice to have: progress for hashing 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")] - -- <&> setRequestHeaders [("Content-Type", "application/octet-stream")] + <&> setRequestResponseTimeout (responseTimeoutMicro (90_000_000)) -- 90 seconds <&> setRequestHeaders [("Content-Encoding", "gzip")] <&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass) + size <- getFileSize img + hashBar <- newProgressBar defStyle 30 (Progress 0 (fromIntegral size) ()) + runConduitRes $ sourceFile img .| transByteCounter hashBar .| sinkHash @_ @SHA256 hash <- hashFile @_ @SHA256 img - -- let z = (createZipEntry img (Just $ fromIntegral size) .| (zipStream zipOptions)) - let compressedFilePath = img <.> "gz" - runResourceT $ - runConduit $ - sourceFile img - .| gzip - .| sinkFileCautious compressedFilePath + let compressedFilePath = "/tmp/eos.img.gz" + zipBar <- newProgressBar defStyle 30 (Progress 0 (fromIntegral size) ()) + runConduitRes $ + sourceFile img + .| gzip + .| transByteCounter zipBar + .| sinkFileCautious compressedFilePath compressedSize <- getFileSize compressedFilePath - bar <- newProgressBar defStyle 30 (Progress 0 (fromIntegral compressedSize) ()) - body <- observedStreamFile (updateProgress bar . const . sfs2prog) $ compressedFilePath + fileBar <- newProgressBar defStyle 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 withSource = setRequestBodySource (fromIntegral size) _ withQParams manager <- newTlsManager res <- runReaderT (httpLbs withQParams) manager - removeFile $ compressedFilePath + removeFile compressedFilePath if getResponseStatus res == status200 then -- no output is successful pure () @@ -637,30 +633,15 @@ eosUpload (EosUpload name img version) = do where sfs2prog :: StreamFileStatus -> Progress () sfs2prog StreamFileStatus{..} = Progress (fromIntegral readSoFar) (fromIntegral fileSize) () - zipOptions = - ZipOptions - { zipOpt64 = True - , 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 - utcTime <- liftIO getCurrentTime - localTimeZone <- liftIO $ getTimeZone utcTime - let zipEntry = - ZipEntry - { zipEntryName = Left $ T.pack "eos.img.gz" - , zipEntryTime = utcToLocalTime localTimeZone utcTime - , zipEntrySize = size - , zipEntryExternalAttributes = Nothing - } - yield (zipEntry, d) + 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 ()