zip eos image on upload

package.yaml

@@ -74,6 +74,7 @@ dependencies:
   - yesod-auth-basic
   - yesod-core
   - yesod-persistent
+  - zip-stream
 
 library:
   source-dirs: src

src/Cli/Cli.hs

@@ -29,6 +29,7 @@ import Crypto.Hash (
     SHA256 (SHA256),
     hashWith,
  )
+import Crypto.Hash.Conduit (hashFile)
 import Data.Aeson (
     ToJSON,
     eitherDecodeStrict,
@@ -70,9 +71,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 (
@@ -90,7 +89,8 @@ import Network.HTTP.Simple (
     parseRequest,
     setRequestBody,
     setRequestBodyJSON,
-    setRequestHeaders, setRequestQueryString
+    setRequestHeaders,
+    setRequestQueryString,
  )
 import Network.HTTP.Types (status200)
 import Network.URI (
@@ -150,6 +150,7 @@ import Startlude (
     IsString (..),
     Maybe (..),
     Monad ((>>=)),
+    Num (fromInteger),
     ReaderT (runReaderT),
     Semigroup ((<>)),
     Show,
@@ -205,7 +206,6 @@ import Yesod (
     logError,
     logWarn,
  )
-import Crypto.Hash.Conduit (hashFile)
 
 
 data Upload = Upload
@@ -215,6 +215,7 @@ data Upload = Upload
     }
     deriving (Show)
 
+
 data EosUpload = EosUpload
     { eosRepoName :: !String
     , eosPath :: !FilePath
@@ -429,6 +430,7 @@ parsePkgCat = subparser $ command "categorize" (info cat $ progDesc "Add or remo
                     <*> strArgument (metavar "PACKAGE_ID")
                     <*> strArgument (metavar "CATEGORY")
 
+
 parseEosPublish :: Parser EosUpload
 parseEosPublish =
     subparser $
@@ -572,19 +574,25 @@ 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
     PublishCfgRepo{..} <- findNameInCfg name
+    size <- fromInteger <$> getFileSize img
     noBody <-
         parseRequest ("POST " <> show publishCfgRepoLocation <> "/admin/v0/eos-upload")
             <&> setRequestHeaders [("accept", "text/plain")]
+            <&> setRequestHeaders [("Content-Encoding", "gzip")]
+            <&> setRequestHeaders [("Content-Length", show size)]
             <&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass)
-    size <- getFileSize img
     hash <- hashFile @_ @SHA256 img
     bar <- newProgressBar defStyle 30 (Progress 0 (fromIntegral size) ())
     body <- observedStreamFile (updateProgress bar . const . sfs2prog) img
     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
     if getResponseStatus res == status200
@@ -598,6 +606,7 @@ eosUpload (EosUpload name img version) = do
         sfs2prog :: StreamFileStatus -> Progress ()
         sfs2prog StreamFileStatus{..} = Progress (fromIntegral readSoFar) (fromIntegral fileSize) ()
 
+
 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,11 +5,30 @@
 
 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,
+    fuseBoth,
     runConduit,
     sinkFile,
+    sinkFileBS,
+    yield,
     (.|),
  )
+import Control.Monad.Extra
 import Control.Monad.Reader.Has (ask)
 import Control.Monad.Trans.Maybe (MaybeT (..))
 import Data.Aeson (
@@ -22,6 +41,7 @@ import Data.Aeson (
     (.:?),
     (.=),
  )
+import Data.ByteString (ByteString)
 import Data.HashMap.Internal.Strict (
     HashMap,
     differenceWith,
@@ -35,6 +55,7 @@ import Data.List (
 import Data.String.Interpolate.IsString (
     i,
  )
+import Data.Time
 import Database.Persist (
     Entity (entityKey),
     PersistStoreRead (get),
@@ -64,9 +85,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 (
@@ -90,28 +109,29 @@ import Settings
 import Startlude (
     Applicative (pure),
     Bool (..),
+    Either (Right),
     Eq,
+    FilePath,
     Int,
     Maybe (..),
-    Monad ((>>=)),
     Show,
     SomeException (..),
     Text,
+    Word64,
     asum,
-    fmap,
+    decodeUtf8,
+    encodeUtf8,
     fromMaybe,
-    getCurrentTime,
     guarded,
     hush,
     isNothing,
     liftIO,
     not,
+    readMaybe,
     replicate,
     show,
     toS,
     traverse,
-    void,
-    when,
     zip,
     ($),
     (&&&),
@@ -140,6 +160,7 @@ import Yesod (
     delete,
     getsYesod,
     logError,
+    lookupHeader,
     rawRequestBody,
     requireCheckJsonBody,
     runDB,
@@ -193,16 +214,41 @@ 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 `fuseBoth` sinkFileBS 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
         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

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"