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/Cli/Cli.hs b/src/Cli/Cli.hs index b27c6b1..70be6b1 100644 --- a/src/Cli/Cli.hs +++ b/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, - sinkNull, + sinkFileCautious, + 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) ()) - body <- observedStreamFile (updateProgress bar . const . sfs2prog) img - let r = liftIO $ runResourceT $ runConduit $ (createZipEntry img (Just $ fromIntegral size) .| void (zipStream zipOptions)) .| sinkHandle stdout - + -- let z = (createZipEntry img (Just $ fromIntegral size) .| (zipStream zipOptions)) + let compressedFilePath = img <.> "gz" + 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) diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 6bf8613..ea60877 100644 --- a/src/Handler/Admin.hs +++ b/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