WIP: Haskell impl of resizeImageToStrSize

package.yaml

@@ -50,6 +50,8 @@ dependencies:
   - unliftio-core == 0.2.*
   - uuid == 1.3.*
   - zip == 2.0.*
+  - JuicyPixels
+  - JuicyPixels-stbir
 
 flags:
   swift:

simplex-chat.cabal

@@ -35,6 +35,7 @@ library
       Simplex.Chat.Core
       Simplex.Chat.Files
       Simplex.Chat.Help
+      Simplex.Chat.Image
       Simplex.Chat.Markdown
       Simplex.Chat.Messages
       Simplex.Chat.Messages.Batch
@@ -198,7 +199,9 @@ library
       StrictData
   ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns
   build-depends:
-      aeson ==2.2.*
+      JuicyPixels
+    , JuicyPixels-stbir
+    , aeson ==2.2.*
     , ansi-terminal >=0.10 && <0.12
     , async ==2.2.*
     , attoparsec ==0.14.*
@@ -261,7 +264,9 @@ executable simplex-bot
       StrictData
   ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -threaded
   build-depends:
-      aeson ==2.2.*
+      JuicyPixels
+    , JuicyPixels-stbir
+    , aeson ==2.2.*
     , ansi-terminal >=0.10 && <0.12
     , async ==2.2.*
     , attoparsec ==0.14.*
@@ -325,7 +330,9 @@ executable simplex-bot-advanced
       StrictData
   ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -threaded
   build-depends:
-      aeson ==2.2.*
+      JuicyPixels
+    , JuicyPixels-stbir
+    , aeson ==2.2.*
     , ansi-terminal >=0.10 && <0.12
     , async ==2.2.*
     , attoparsec ==0.14.*
@@ -392,7 +399,9 @@ executable simplex-broadcast-bot
       Paths_simplex_chat
   ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -threaded
   build-depends:
-      aeson ==2.2.*
+      JuicyPixels
+    , JuicyPixels-stbir
+    , aeson ==2.2.*
     , ansi-terminal >=0.10 && <0.12
     , async ==2.2.*
     , attoparsec ==0.14.*
@@ -457,7 +466,9 @@ executable simplex-chat
       StrictData
   ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -threaded
   build-depends:
-      aeson ==2.2.*
+      JuicyPixels
+    , JuicyPixels-stbir
+    , aeson ==2.2.*
     , ansi-terminal >=0.10 && <0.12
     , async ==2.2.*
     , attoparsec ==0.14.*
@@ -528,7 +539,9 @@ executable simplex-directory-service
       Paths_simplex_chat
   ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -threaded
   build-depends:
-      aeson ==2.2.*
+      JuicyPixels
+    , JuicyPixels-stbir
+    , aeson ==2.2.*
     , ansi-terminal >=0.10 && <0.12
     , async ==2.2.*
     , attoparsec ==0.14.*
@@ -599,6 +612,7 @@ test-suite simplex-chat-test
       ChatTests.Profiles
       ChatTests.Utils
       JSONTests
+      LinkPreviewTests
       MarkdownTests
       MessageBatching
       MobileTests
@@ -625,7 +639,9 @@ test-suite simplex-chat-test
       StrictData
   ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -threaded
   build-depends:
-      QuickCheck ==2.14.*
+      JuicyPixels
+    , JuicyPixels-stbir
+    , QuickCheck ==2.14.*
     , aeson ==2.2.*
     , ansi-terminal >=0.10 && <0.12
     , async ==2.2.*

src/Simplex/Chat/Image.hs

@@ -0,0 +1,112 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module Simplex.Chat.Image where
+
+import qualified Data.ByteString.Base64.Lazy as LB64
+import qualified Data.ByteString.Lazy.Char8 as LB
+import qualified Codec.Picture as Picture
+import Codec.Picture.Jpg (encodeDirectJpegAtQualityWithMetadata)
+import Codec.Picture.Png (encodePng)
+import qualified Codec.Picture.STBIR as STBIR
+import Codec.Picture.Types (dropAlphaLayer, pixelFoldMap)
+import Data.Int (Int64)
+import Data.Monoid (All(..))
+import Data.Word (Word8)
+
+resizeImageToStrSize :: Int64 -> ResizeableImage -> Maybe LB.ByteString
+resizeImageToStrSize maxSize (ResizeableImage fmt img encoder) = either resizePNG resizeJPG encoder
+  where
+    halveAndRetry = resizeImageToStrSize maxSize $ ResizeableImage fmt imgHalved encoder
+    imgHalved = downscale img 2.0
+    resizePNG enc
+      | LB.length encoded <= maxSize = Just encoded
+      | LB.length (encode imgHalved) > maxSize = halveAndRetry
+      | otherwise = Just $ fitScale 1.0 2.0
+      where
+        encode = toDataUri "png" enc
+        encoded = encode img
+        fitScale l u
+          | u - l < 1 / 64 = encode $ downscale img u -- prefer lower resolution
+          | otherwise =
+              case compare maxSize (LB.length result) of
+                LT -> fitScale m u -- over budget, scale harder
+                EQ -> result
+                GT -> fitScale l m -- keep more pixels
+              where
+                m = (l + u) / 2
+                result = encode $ downscale img m
+    resizeJPG enc -- if minSize > maxSize then halveAndRetry else Just $ fitQuality 33 99
+      | minSize > maxSize = halveAndRetry
+      | otherwise = Just $ fitQuality 33 99
+      where
+        encode q = toDataUri "jpeg" (enc q) img
+        minSize = LB.length $ encode 33
+        -- fitQuality = binarySearch (\l u -> (l + u) `div` 2) (\l u -> u - l <= 1) encode score 50 99
+        fitQuality l u
+          | u - l <= 1 = encode l -- prefer higher compression
+          | otherwise =
+              case compare (LB.length result) maxSize of
+                LT -> fitQuality m u -- keep more data
+                EQ -> result
+                GT -> fitQuality l m -- over budget, reduce quality
+              where
+                m = (l + u) `div` 2
+                result = encode m
+
+downscale :: STBIR.STBIRPixel pixel => Picture.Image pixel -> Float -> Picture.Image pixel
+downscale img scale = STBIR.resize STBIR.defaultOptions (scaled Picture.imageWidth) (scaled Picture.imageHeight) img
+  where
+    scaled f = round $ fromIntegral (f img) / min 2.0 (max 0.5 scale)
+
+toDataUri :: LB.ByteString -> (Picture.Image a -> LB.ByteString) -> Picture.Image a -> LB.ByteString
+toDataUri fmt enc img = "data:image/" <> fmt <> ";base64," <> LB64.encode (enc img)
+
+tryDropOpacity :: Picture.DynamicImage -> Picture.DynamicImage
+tryDropOpacity dyn = case dyn of
+  Picture.ImageRGBA16 img | opaque img -> Picture.ImageRGB16 $ dropAlphaLayer img
+  Picture.ImageRGBA8 img | opaque img -> Picture.ImageRGB8 $ dropAlphaLayer img
+  Picture.ImageYA16 img | opaque img -> Picture.ImageY16 $ dropAlphaLayer img
+  Picture.ImageYA8 img | opaque img -> Picture.ImageY8 $ dropAlphaLayer img
+  _ -> dyn
+  where
+    opaque :: (Picture.Pixel a, Eq (Picture.PixelBaseComponent a), Bounded (Picture.PixelBaseComponent a)) => Picture.Image a -> Bool
+    opaque = getAll . pixelFoldMap (All . \pix -> Picture.pixelOpacity pix == maxBound)
+
+data ResizeableImage where
+  ResizeableImage
+    :: (STBIR.STBIRPixel a) -- , ToDynamicImage a)
+    => String -- ^ format label
+    -> Picture.Image a -- ^ current image data
+    -> ImageEncoder a
+    -> ResizeableImage
+
+type ImageEncoder a = Either (PNGEncoder a) (JPGEncoder a)
+type PNGEncoder a = Picture.Image a -> LB.ByteString
+type JPGEncoder a = Word8 -> Picture.Image a -> LB.ByteString
+
+resizeableImage :: Picture.DynamicImage -> Maybe ResizeableImage
+resizeableImage dyn = case dyn of
+  Picture.ImageY8 img -> Just $ ResizeableImage "Y8" img $ Right $ \q -> encodeDirectJpegAtQualityWithMetadata q mempty
+  Picture.ImageY16 img -> Just $ ResizeableImage "Y16" img $ Left encodePng
+  Picture.ImageY32 _ -> Nothing
+  Picture.ImageYF _ -> Nothing
+  Picture.ImageYA8 img -> Just $ ResizeableImage "YA8" img $ Left encodePng
+  Picture.ImageYA16 img -> Just $ ResizeableImage "YA16" img $ Left encodePng
+  Picture.ImageRGB8 img -> Just $ ResizeableImage "RGB8" img $ Right $ \q -> encodeDirectJpegAtQualityWithMetadata q mempty
+  Picture.ImageRGB16 img -> Just $ ResizeableImage "RGB16" img $ Left encodePng
+  Picture.ImageRGBF _ -> Nothing
+  Picture.ImageRGBA8 img -> Just $ ResizeableImage "RGBA8" img $ Left encodePng
+  Picture.ImageRGBA16 img -> Just $ ResizeableImage "RGBA16" img $ Left encodePng
+  Picture.ImageYCbCr8 img -> Just $ ResizeableImage "YCbCr8" img $ Right $ \q -> encodeDirectJpegAtQualityWithMetadata q mempty
+  Picture.ImageCMYK8 img -> Just $ ResizeableImage "CMYK8" img $ Right $ \q -> encodeDirectJpegAtQualityWithMetadata q mempty
+  Picture.ImageCMYK16 _ -> Nothing
+  -- STBIR says all types currently covered by JP's 'Pixel' are supported.

tests/LinkPreviewTests.hs

@@ -0,0 +1,36 @@
+module LinkPreviewTests where
+
+import qualified Data.ByteString.Base64.Lazy as LB64
+import qualified Data.ByteString.Lazy.Char8 as LB
+import qualified Codec.Picture as Picture
+import Control.Logger.Simple
+import Control.Monad
+import Simplex.Chat.Image (ResizeableImage (..), resizeableImage, resizeImageToStrSize, tryDropOpacity)
+import Simplex.Messaging.Util (tshow)
+import Test.Hspec
+
+linkPreviewTests :: SpecWith FilePath
+linkPreviewTests = do
+  fdescribe "Image resize" $ do
+    it "JPG" $ resizeToStrTest "tests/fixtures/test.jpg"
+    it "PNG with alpha" $ resizeToStrTest "tests/fixtures/logo-large-rgba.png"
+    it "PNG without alpha" $ resizeToStrTest "tests/fixtures/preview-issue1.png"
+
+resizeToStrTest :: FilePath -> FilePath -> IO ()
+resizeToStrTest inputPath tmp = do
+  (input, metadata) <- Picture.readImageWithMetadata inputPath >>= either error pure
+  case resizeableImage (tryDropOpacity input) of
+    Nothing -> error "Unsupported format"
+    Just image@(ResizeableImage imgFormat _img encoder) -> do
+      logDebug $ tshow (metadata, imgFormat, either (const "png") (const "jpeg") encoder)
+      case resizeImageToStrSize maxSize image of
+        Nothing -> error "Unable to resize"
+        Just lbs -> do
+          let finalSize = LB.length lbs
+          unless (finalSize <= maxSize) $ error $ "Final size larger than maximum size: " <> show (finalSize, maxSize)
+          let (fmt, b64) = fmap (LB.drop 8) . LB.break (== ';') $ LB.drop 11 lbs
+              outFile = tmp ++ "/out." ++ LB.unpack fmt
+          either error (LB.writeFile outFile) $ LB64.decode b64
+          Picture.readImageWithMetadata outFile >>= either error (logDebug . tshow . snd)
+  where
+    maxSize = 14000

tests/Test.hs

@@ -6,6 +6,7 @@ import ChatTests.Utils (xdescribe'')
 import Control.Logger.Simple
 import Data.Time.Clock.System
 import JSONTests
+import LinkPreviewTests
 import MarkdownTests
 import MessageBatching
 import MobileTests
@@ -21,7 +22,7 @@ import WebRTCTests
 
 main :: IO ()
 main = do
-  setLogLevel LogError
+  setLogLevel LogDebug
   withGlobalLogging logCfg . hspec $ do
     describe "Schema dump" schemaDumpTest
     describe "SimpleX chat markdown" markdownTests
@@ -38,6 +39,7 @@ main = do
       xdescribe'' "SimpleX Broadcast bot" broadcastBotTests
       xdescribe'' "SimpleX Directory service bot" directoryServiceTests
       describe "Remote session" remoteTests
+    around testBracket $ describe "Link preview" linkPreviewTests
   where
     testBracket test = withSmpServer $ tmpBracket test
     tmpBracket test = do