diff --git a/package.yaml b/package.yaml index d98b470be9..bfbfcbfb9d 100644 --- a/package.yaml +++ b/package.yaml @@ -50,6 +50,8 @@ dependencies: - unliftio-core == 0.2.* - uuid == 1.3.* - zip == 2.0.* + - JuicyPixels + - JuicyPixels-stbir flags: swift: diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 6913ddc14d..930da32c30 100644 --- a/simplex-chat.cabal +++ b/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.* diff --git a/src/Simplex/Chat/Image.hs b/src/Simplex/Chat/Image.hs new file mode 100644 index 0000000000..9715f0a2a6 --- /dev/null +++ b/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. diff --git a/tests/LinkPreviewTests.hs b/tests/LinkPreviewTests.hs new file mode 100644 index 0000000000..7fb05294fe --- /dev/null +++ b/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 diff --git a/tests/Test.hs b/tests/Test.hs index 3d59b840dd..ee40822e8f 100644 --- a/tests/Test.hs +++ b/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 diff --git a/tests/fixtures/logo-large-rgba.png b/tests/fixtures/logo-large-rgba.png new file mode 100644 index 0000000000..b42ccaefa1 Binary files /dev/null and b/tests/fixtures/logo-large-rgba.png differ diff --git a/tests/fixtures/preview-issue1.png b/tests/fixtures/preview-issue1.png new file mode 100644 index 0000000000..a3b34bf751 Binary files /dev/null and b/tests/fixtures/preview-issue1.png differ