core, ui: resize images in the core for sharper previews and images (#7941)

* WIP: Haskell impl of resizeImageToStrSize

* WIP: add FFI export wrapper

* WIP: switch ios resizeImageToStrSizeSync to backend

* WIP: fix resizeImageToStrSizeSync

* WIP: add JNI wrappers

* Add non-base64 resize and cWriteImage

* WIP: add chat_write_image

* fix resizeToStr

* fixes

* fix syntax, raise jpeg quality back

* add chatWriteImage

* Fix cfArgs in tests

* Use jpeg-turbo encoder

* add nix pins

* bump jpeg-turbo

* add CI deps

* add encoding funs to android lib

* bump jpeg-turbo for 20.04 fix

* jpeg-turbo fix for 8.10

* android fixes

* Bump jpeg-turbo

* set static flag for jpeg-turbo

* Fix nix for aarch64/android

* Fix android C api

* Fix resize in android

* Bump hs-libjpeg-turbo

* target correct override

* override android lib from android pkgs

* add macos build tweaks

* bump hs-jpeg-turbo for 8.10 fixes

* more build fixes

* make ios compile

* Always use pkgconfig for libjpeg-turbo

* WIP: debug libjpeg in ubuntu pkg-config CI

* Add pkg-config to dockerfiles

* Add libturbojpeg to dockerfiles

* Use -dev version of libturbojpeg in dockerfiles

* Install pkg-config in windows CI

* Disable flag for custom libturbojpeg linking options

Workarounds relocation error on x86_64-linux with gcc:
  /usr/bin/ld: /usr/lib/gcc/x86_64-linux-gnu/13/../../../x86_64-linux-gnu/libturbojpeg.a(turbojpeg.c.o): relocation R_X86_64_TPOFF32 against `errStr' can not be used when making a shared object; recompile with -fPIC
  /usr/bin/ld: failed to set dynamic section sizes: bad value

* WIP: debug libjpeg in windows pkg-config CI

* WIP: debug libjpeg package in windows CI

* core: image resize module and buffer FFI

* ci: link libjpeg-turbo statically on all platforms

* ui: resize images in the core

* core: rename image resize functions to chat_resize_image and chat_resize_image_uri

* ci: restore whitespace in build.yml

* ci: build libjpeg-turbo 3.1.4.1 from a submodule

* core: hs-jpeg-turbo from github.com/simplex-chat

* nodejs: resize images

* python: resize images

* core: hs-jpeg-turbo from gitlab.com, the GitHub import lacks LFS objects

* core: generate /img previews

* ci: link libjpeg-turbo on Windows without pkg-config

* ci: build libjpeg-turbo on Windows with the GHC toolchain

* docs: plan for image resizing in the core

* docs: update image resizing plan

* ios: prevent crash when wallpaper image cannot be resized

* android, desktop: raise an error when an image cannot be resized

* docs: update spec references for image resizing

* docker: build the CLI image from a clone without submodules

* docs: apply review fixes to image resizing plan

* docker: build the CLI from a git worktree with the submodule present

* docs: apply second review to image resizing plan

* docs: point image resizing plan at the rewritten commit

* core: choose image format by transparency in chat_resize_image

* nodejs: resize images to the app sizes

* python: resize images to the app sizes

* nodejs, python: describe the core modules as used for image resizing

* docs: add license notices of the image libraries

* ci: describe the avatar method without attributing it to the apps

* ci, ios, nix: remove the libjpeg-turbo build outside cabal

* python: name resize_image in the core module text

* nodejs, python: describe resizing to the app image sizes

* core: refuse images larger than the supported size

* core: resize to JPEG images with a side above 65500 pixels

* docs: record image resizing decisions for the bundled libjpeg-turbo

* core, docs: build libjpeg-turbo and stb from the fork submodules

* docs: record the fork pins in the image resizing plan

* core: resize images to at most 4320 pixels per side, refuse above 16384

* docs: record the image side limits in the image resizing plan

* core: pin the rebased hs-jpeg-turbo fork

* core: pin the hs-jpeg-turbo fork without package.yaml

* docs: plan scaled JPEG decoding and EXIF orientation of images

* docs: copy the JuicyPixels-stbir licence of the pinned fork

* core: pin the hs-jpeg-turbo fork with scaled JPEG decoding

* core: decode JPEG at the display size, up to 65500 pixels per side

* core: rotate JPEG images by their EXIF orientation

* docs: refer the image plan to the JPEG decoding code

* docs: record the approved image processing decisions

* core: limit JPEG decoding memory to 1024 MB outside iOS and Android

* docs: name JPEG decoding in the libjpeg-turbo notice

* docs: plan image resizing from files and the decisions of 26 Oct

* core: scale images in one Catmull-Rom pass with sharpening

* docs: plan image sizes at a fixed quality

* core: resize images at a fixed quality to fill the size limit

* core: resize images from a file path or a file descriptor

* ios, android, desktop: resize picked images from their files

* core: encode resized images with mozjpeg

* tests: check descriptor closing by the file it refers to

* core: raise JPEG quality only for a full-size image below 97% of the limit

* ci: name the mozjpeg submodule in the Windows cleanup comments

* docs: refer the image plan to the current code

* docs: refer the image plan to the code merged with master

* core: export every image resizing function from each library

* core: close the file descriptor when its handle cannot be created

* docs: count the C sources of mozjpeg with the arithmetic decoder

* core: use the reviewed hs-jpeg-turbo and JuicyPixels-stbir forks

* ci: build the armv7a Android core library on request

* core: round image heights half up in the size search

* ios: describe the file image resizing functions in SimpleX.h

* ci: pick, preview and send images in the Claude app tests

* core: decode PNG images with libspng and refuse other formats

* core: encode PNG with libspng, keeping the smaller filter choice

* ci: pick, preview and send images in the scripted app smoke tests

* flake: build the PNG decoder package in nix builds

* ios: remove the copy of a picked image after sending it

* core: refuse image files larger than the decode memory limit

* core: scale a JPEG image to its largest size once per resize

* core: bisect JPEG quality without a step function

* core: reduce the memory used to sharpen and to decode PNG images

* android, desktop: pass the image format to the core as an integer

* android, desktop: fuse the preview conditions of picked media

* android, desktop, ci: check that the core resized the smoke test images

* python: remove the docstrings of the explicit image resizing functions

* docs: add the second review fixes to the image plan

* ci: tap the iOS attachment button by its accessibility label

* core: keep the colour profiles of resized images

* docs: add the colour profiles to the image plan

* ci: wait up to 30 s for the new group screens in the iOS smoke test

* ci: pick the Android smoke test images from their own photo folders

* ci: tap the iOS photo picker by position, as its tree is not shown

* ci: pick the test card and the logo by their iOS picker positions

* core: update JuicyPixels-stbir with the stb_image_resize licence terms

* core: write a fixed Display P3 profile for Display P3 images only

* core: do not keep the input image in memory for its colour profile

* core: read the JPEG segments once for the orientation and the profile

* core: read an image file into one buffer of its size

* docs: add the third review fixes to the image plan

* core: resize images with Display P3 or no profile, not profile bytes

* ci: check the pixel sizes of the images sent in the iOS smoke test

* core: update hs-jpeg-turbo with PNG chunk limits and encoder fixes

* docs: list Compact ICC Profiles, libspng and miniz in the dependencies

* android, desktop: reword the picked media preview comment

* docs: refer the image plan to the code merged with master

* ci: render the iOS snapshots before the images case

* ci: dismiss the snapshot tests' camera alert before the iOS images case

* core: update hs-jpeg-turbo with tests and the JuicyPixels-spng synopsis

* core: pin hs-jpeg-turbo and JuicyPixels-stbir in simplex-chat repositories

* update ios core library

* core, ui: accept only JPEG and PNG image data

* core: update JuicyPixels-stbir

* docs: plan for the iOS copy of picked images

---------

Co-authored-by: IC Rainbow <aenor.realm@gmail.com>
Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>
Co-authored-by: Alexandre Esteves <alexfmpe@proton.me>

src/Simplex/Chat/Image.hs

@@ -0,0 +1,407 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
+
+module Simplex.Chat.Image
+  ( ImageFormat (..),
+    ColourProfile (..),
+    imageFormat,
+    decodeResizable,
+    resizeImage,
+    resizeImageDataUri,
+    maxDecodeMemoryMB,
+    scaleRGB8,
+    scaleRGBA8,
+  )
+where
+
+import Codec.Picture (DynamicImage (..), Image (..), Pixel (..), PixelRGB8, PixelRGBA8 (..), convertRGB8, convertRGBA8, dynamicMap, dynamicPixelMap, generateImage, pixelMap)
+import Codec.Picture.JPEGTurbo (DecodeOptions (DecodeOptions), JpegHeader (..), Scale (..), decodeJpeg, encodeRGB, readJpegHeader)
+import qualified Codec.Picture.STBIR as STBIR
+import qualified Codec.Picture.Spng as Spng
+import Codec.Picture.Types (pixelFoldMap)
+import Control.Monad (forM_, guard, when, (<=<))
+import Control.Monad.Except (ExceptT (..), runExceptT, throwError)
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Base64.Lazy as LB64
+import qualified Data.ByteString.Lazy.Char8 as LB
+import Data.FileEmbed (embedFile)
+import Data.Int (Int32, Int64)
+import Data.List (maximumBy, minimumBy, sortOn)
+import Data.Maybe (fromMaybe, listToMaybe)
+import Data.Monoid (All (..))
+import Data.Ord (comparing)
+import qualified Data.Vector.Storable as VS
+import qualified Data.Vector.Storable.Mutable as VSM
+import Data.Word (Word8)
+import GHC.Float (double2Float, float2Double)
+
+data ImageFormat = IFJpeg | IFPng
+
+data ColourProfile = CPNone | CPDisplayP3
+  deriving (Eq, Show)
+
+imageFormat :: DynamicImage -> ImageFormat
+imageFormat = \case
+  ImageYA8 img -> alphaFormat img
+  ImageYA16 img -> alphaFormat img
+  ImageRGBA8 img -> alphaFormat img
+  ImageRGBA16 img -> alphaFormat img
+  _ -> IFJpeg
+  where
+    alphaFormat :: (Pixel a, Eq (PixelBaseComponent a), Bounded (PixelBaseComponent a)) => Image a -> ImageFormat
+    alphaFormat img
+      | getAll $ pixelFoldMap (All . (maxBound ==) . pixelOpacity) img = IFJpeg
+      | otherwise = IFPng
+
+decodeResizable :: ByteString -> IO (Either String (DynamicImage, ColourProfile))
+decodeResizable s = runExceptT $ do
+  (img, profile) <- decode
+  pure . (img,) $! maybe CPNone colourProfile profile
+  where
+    decode
+      | "\xFF\xD8" `B.isPrefixOf` s = decodeDisplayJpeg s
+      | "\x89PNG\r\n\x1a\n" `B.isPrefixOf` s = ExceptT $ Spng.decodePng (Spng.DecodeOptions $ maxDecodeMemoryMB `div` 2) s
+      | otherwise = throwError "unsupported image format"
+
+decodeDisplayJpeg :: ByteString -> ExceptT String IO (DynamicImage, Maybe ByteString)
+decodeDisplayJpeg s = do
+  JpegHeader {jpegWidth, jpegHeight} <- ExceptT $ readJpegHeader s
+  (halvings, size) <- maybe (throwError "image does not fit") pure $ displaySize jpegWidth jpegHeight
+  (,jpegIccProfile segments) . orientImage (exifOrientation segments) . resizeToSize size <$> ExceptT (decodeJpeg (DecodeOptions (jpegScale halvings) maxJpegPixels maxDecodeMemoryMB) s)
+  where
+    segments = jpegSegments $ B.drop 2 s
+
+displaySize :: Int -> Int -> Maybe (Int, (Int, Int))
+displaySize = go 0
+  where
+    go n w h
+      | w <= maxDisplaySide && h <= maxDisplaySide = Just (n, (w, h))
+      | w < 2 || h < 2 = Nothing
+      | otherwise = go (n + 1) (scaledSide 2 w) (scaledSide 2 h)
+
+jpegScale :: Int -> Scale
+jpegScale = \case
+  0 -> Full
+  1 -> Half
+  2 -> Quarter
+  _ -> Eighth
+
+resizeToSize :: (Int, Int) -> DynamicImage -> DynamicImage
+resizeToSize size@(w, h) img
+  | dynamicMap (hasSize size) img = img
+  | otherwise = ImageRGB8 $ STBIR.resize STBIR.defaultOptions w h $ convertRGB8 img
+
+exifOrientation :: [(Word8, ByteString)] -> Int
+exifOrientation segments = fromMaybe 1 $ do
+  tiff <- exifTiff segments
+  order <- case B.take 2 tiff of
+    "II" -> Just B.reverse
+    "MM" -> Just id
+    _ -> Nothing
+  let field n i
+        | i < 0 || B.length bytes /= n = Nothing
+        | otherwise = Just $ B.foldl' (\a b -> a * 256 + fromIntegral b) 0 $ order bytes
+        where
+          bytes = B.take n $ B.drop i tiff
+      u16 = field 2
+  ifd <- field 4 4
+  entries <- u16 ifd
+  listToMaybe
+    [ v
+      | e <- [ifd + 2 + 12 * k | k <- [0 .. entries - 1]],
+        u16 e == Just 0x0112,
+        u16 (e + 2) == Just 3,
+        Just v <- [u16 (e + 8)],
+        v >= 1 && v <= 8
+    ]
+
+exifTiff :: [(Word8, ByteString)] -> Maybe ByteString
+exifTiff segments = listToMaybe [B.drop 6 segment | (0xE1, segment) <- segments, "Exif\0\0" `B.isPrefixOf` segment]
+
+jpegIccProfile :: [(Word8, ByteString)] -> Maybe ByteString
+jpegIccProfile segments = do
+  chunks <- sortOn (\(n, _, _) -> n) <$> mapM iccChunk iccSegments
+  let profile = B.concat [chunk | (_, _, chunk) <- chunks]
+  guard $ [n | (n, _, _) <- chunks] == [1 .. length chunks] && all (\(_, count, _) -> count == length chunks) chunks && not (B.null profile)
+  pure profile
+  where
+    iccSegments = [segment | (0xE2, segment) <- segments, "ICC_PROFILE\0" `B.isPrefixOf` segment]
+    iccChunk segment
+      | B.length segment < 14 = Nothing
+      | otherwise = Just (fromIntegral $ B.index segment 12, fromIntegral $ B.index segment 13, B.drop 14 segment)
+
+jpegSegments :: ByteString -> [(Word8, ByteString)]
+jpegSegments s
+  | B.length s < 4 || B.index s 0 /= 0xFF || marker == 0xDA = []
+  | otherwise = (marker, B.take (len - 2) $ B.drop 4 s) : jpegSegments (B.drop (2 + len) s)
+  where
+    marker = B.index s 1
+    len = fromIntegral (B.index s 2) * 256 + fromIntegral (B.index s 3)
+
+orientImage :: Int -> DynamicImage -> DynamicImage
+orientImage orientation = dynamicPixelMap orient
+  where
+    orient :: Pixel a => Image a -> Image a
+    orient img@Image {imageWidth = w, imageHeight = h} = case orientation of
+      2 -> generateImage (\x y -> pixelAt img (w - 1 - x) y) w h
+      3 -> generateImage (\x y -> pixelAt img (w - 1 - x) (h - 1 - y)) w h
+      4 -> generateImage (\x y -> pixelAt img x (h - 1 - y)) w h
+      5 -> generateImage (\x y -> pixelAt img y x) h w
+      6 -> generateImage (\x y -> pixelAt img y (h - 1 - x)) h w
+      7 -> generateImage (\x y -> pixelAt img (w - 1 - y) (h - 1 - x)) h w
+      8 -> generateImage (\x y -> pixelAt img (w - 1 - y) x) h w
+      _ -> img
+
+colourProfile :: ByteString -> ColourProfile
+colourProfile profile = fromMaybe CPNone $ do
+  primaries <- iccPrimaries profile
+  p3Primaries <- iccPrimaries displayP3
+  CPDisplayP3 <$ guard (and $ zipWith (\v v' -> abs (v - v') <= 2) primaries p3Primaries)
+
+iccPrimaries :: ByteString -> Maybe [Integer]
+iccPrimaries profile = do
+  guard $ slice 16 4 == Just "RGB " && slice 20 4 == Just "XYZ "
+  count <- unsigned <$> slice 128 4
+  table <- slice 132 (12 * count)
+  concat <$> mapM (colorant <=< tagEntry table) ["rXYZ", "gXYZ", "bXYZ"]
+  where
+    tagEntry entries sig
+      | B.null entries = Nothing
+      | B.take 4 entries == sig = Just $ B.take 12 entries
+      | otherwise = tagEntry (B.drop 12 entries) sig
+    colorant entry = do
+      let offset = unsigned $ B.take 4 $ B.drop 4 entry
+          size = unsigned $ B.drop 8 entry
+      guard $ size >= 20
+      tag <- slice offset size
+      guard $ "XYZ " `B.isPrefixOf` tag
+      pure [s15Fixed16 $ B.take 4 $ B.drop i tag | i <- [8, 12, 16]]
+    slice i n
+      | i + n > toInteger (B.length profile) = Nothing
+      | otherwise = Just $ B.take (fromInteger n) $ B.drop (fromInteger i) profile
+    unsigned = B.foldl' (\a b -> a * 256 + toInteger b) 0
+    s15Fixed16 = toInteger . (fromInteger :: Integer -> Int32) . unsigned
+
+displayP3 :: ByteString
+displayP3 = $(embedFile "src/Simplex/Chat/Image/DisplayP3-v4.icc")
+
+data ImageOutput = ImageBytes | ImageDataUri
+
+resizeImage :: ImageFormat -> Int64 -> DynamicImage -> ColourProfile -> IO (Either String LB.ByteString)
+resizeImage = fitImage ImageBytes
+
+resizeImageDataUri :: Int64 -> DynamicImage -> ColourProfile -> IO (Either String LB.ByteString)
+resizeImageDataUri maxSize img = fitImage ImageDataUri (imageFormat img) maxSize img
+
+fitImage :: ImageOutput -> ImageFormat -> Int64 -> DynamicImage -> ColourProfile -> IO (Either String LB.ByteString)
+fitImage output format maxSize img profile
+  | dynamicMap (hasSideAbove maxImageSide) img = pure imageDoesNotFit
+  | otherwise = maybe (pure imageDoesNotFit) (fitLargest . snd) $ dynamicMap (\i -> displaySize (imageWidth i) (imageHeight i)) img
+  where
+    (out, quality, bitsPerPixel, jpegBytes, outputLength) = case output of
+      ImageBytes -> (id, 65, 0.9, id, id)
+      ImageDataUri -> (toDataUri format, 20, 0.35, \target -> 0.75 * max 0 (target - fromIntegral (LB.length $ toDataUri format "")), \n -> 4 * ((n + 2) `div` 3))
+    keptProfile = displayP3 <$ guard (profile == CPDisplayP3 && fromIntegral (outputLength $ B.length displayP3) <= maxSize `div` 10)
+    fitLargest largest = case format of
+      IFJpeg -> do
+        let rgb = convertRGB8 img
+            largestRGB = scaleRGB8 rgb largest
+            scale size = if size == largest then largestRGB else scaleRGB8 rgb size
+            jpeg q = fmap (out . LB.fromStrict) . encodeRGB q keptProfile
+        fitSize maxSize (Just $ \target -> 8 * jpegBytes target / bitsPerPixel) largest (jpeg quality . scale) >>= \case
+          Right (size, r) | size == largest && fromIntegral (LB.length r) < minFill * fromIntegral maxSize -> Right <$> bisect maxSize (`jpeg` largestRGB) (quality, r) 96
+          r -> pure $ snd <$> r
+      IFPng -> do
+        let png = fmap (out . LB.fromStrict) . encodeSmallerPng keptProfile
+        fmap snd <$> fitSize maxSize Nothing largest (png . scaleRGBA8 (convertRGBA8 img))
+
+fitSize :: Int64 -> Maybe (Double -> Double) -> (Int, Int) -> ((Int, Int) -> IO LB.ByteString) -> IO (Either String ((Int, Int), LB.ByteString))
+fitSize maxSize firstPixels (lw, lh) encode = search [] $ maybe lw (widthFor . ($ target)) firstPixels
+  where
+    search tried w = do
+      r <- encode $ sizeOf w
+      let tried' = (w, r) : tried
+      if fits r && (size r >= minFill * limit || w == lw)
+        then pure $ Right (sizeOf w, r)
+        else maybe (largestFit tried') (search tried') $ nextWidth tried' w r
+    nextWidth tried w r
+      | length tried >= 8 = Nothing
+      | predicted `notElem` map fst tried = Just predicted
+      | hi - lo > 1 = Just $ (lo + hi) `div` 2
+      | otherwise = Nothing
+      where
+        predicted = widthFor $ pixels w * (target / size r) ** (1 / slope tried)
+        lo = maximum $ 0 : map fst (filter (fits . snd) tried)
+        hi = minimum $ lw + 1 : [x | (x, r') <- tried, not (fits r'), x > lo]
+    slope ((w2, r2) : (w1, r1) : _)
+      | w1 /= w2 && size r1 /= size r2 && a >= 0.4 && a <= 1.3 = a
+      where
+        a = log (size r2 / size r1) / log (pixels w2 / pixels w1)
+    slope _ = 0.85
+    largestFit tried = case filter (fits . snd) tried of
+      [] -> shrink $ minimum $ map fst tried
+      fitting -> let (w, r) = maximumBy (comparing fst) fitting in pure $ Right (sizeOf w, r)
+    shrink w
+      | w < 2 = pure imageDoesNotFit
+      | otherwise = do
+          let w' = w `div` 2
+          r <- encode $ sizeOf w'
+          if fits r then pure $ Right (sizeOf w', r) else shrink w'
+    widthFor p = max 1 $ min lw $ round $ sqrt (p * fromIntegral lw / fromIntegral lh)
+    sizeOf w = (w, max 1 $ floor (fromIntegral (w * lh) / fromIntegral lw + 0.5 :: Double))
+    pixels w = let (w', h') = sizeOf w in fromIntegral (w' * h')
+    fits r = LB.length r <= maxSize
+    size = fromIntegral . LB.length
+    limit = fromIntegral maxSize
+    target = sqrt minFill * limit
+
+minFill :: Double
+minFill = 0.97
+
+imageDoesNotFit :: Either String a
+imageDoesNotFit = Left "image does not fit"
+
+bisect :: Int64 -> (Int -> IO LB.ByteString) -> (Int, LB.ByteString) -> Int -> IO LB.ByteString
+bisect maxSize encode = go
+  where
+    go (good, r) bad
+      | bad - good <= 1 = pure r
+      | otherwise = do
+          let m = (good + bad) `div` 2
+          r' <- encode m
+          case compare (LB.length r') maxSize of
+            LT -> go (m, r') bad
+            EQ -> pure r'
+            GT -> go (good, r) m
+
+encodeSmallerPng :: Maybe ByteString -> Image PixelRGBA8 -> IO ByteString
+encodeSmallerPng profile img = minimumBy (comparing B.length) <$> mapM encode [False, True]
+  where
+    encode filtering = either fail pure =<< Spng.encodePng (Spng.EncodeOptions 9 filtering profile) img
+
+maxImageSide :: Int
+maxImageSide = 16384
+
+maxDisplaySide :: Int
+maxDisplaySide = 4320
+
+maxJpegPixels :: Int
+maxJpegPixels = 2 ^ (28 :: Int)
+
+maxDecodeMemoryMB :: Int
+#if defined(mobileBuild)
+maxDecodeMemoryMB = 512
+#else
+maxDecodeMemoryMB = 1024
+#endif
+
+hasSideAbove :: Int -> Image a -> Bool
+hasSideAbove side img = imageWidth img > side || imageHeight img > side
+
+hasSize :: (Int, Int) -> Image a -> Bool
+hasSize (w, h) img = imageWidth img == w && imageHeight img == h
+
+scaleRGB8 :: Image PixelRGB8 -> (Int, Int) -> Image PixelRGB8
+scaleRGB8 img size
+  | hasSize size img = img
+  | otherwise = scaled {imageData = sharpen 3 size $ imageData scaled}
+  where
+    scaled = catmullRom [] size img
+
+scaleRGBA8 :: Image PixelRGBA8 -> (Int, Int) -> Image PixelRGBA8
+scaleRGBA8 img = scale
+  where
+    premultiplied = pixelMap premultiply img
+    scale size
+      | hasSize size img = img
+      | otherwise = pixelMap unpremultiply $ scaled {imageData = sharpen 4 size $ imageData scaled}
+      where
+        scaled = catmullRom [STBIR.flag_ALPHA_PREMULTIPLIED] size premultiplied
+
+catmullRom :: STBIR.STBIRPixel a => [STBIR.Flag] -> (Int, Int) -> Image a -> Image a
+catmullRom flags (w, h) = STBIR.resize options w h
+  where
+    options = STBIR.defaultOptions {STBIR.flags = flags, STBIR.filterHorizontal = STBIR.FILTER_CATMULLROM, STBIR.filterVertical = STBIR.FILTER_CATMULLROM}
+
+premultiply :: PixelRGBA8 -> PixelRGBA8
+premultiply (PixelRGBA8 r g b a) = PixelRGBA8 (multiply r) (multiply g) (multiply b) a
+  where
+    multiply c = fromIntegral ((fromIntegral c * fromIntegral a + 127) `div` 255 :: Int)
+
+unpremultiply :: PixelRGBA8 -> PixelRGBA8
+unpremultiply (PixelRGBA8 r g b a) = PixelRGBA8 (divide r) (divide g) (divide b) a
+  where
+    divide c
+      | a == 0 = 0
+      | otherwise = fromIntegral (min 255 $ (fromIntegral c * 255 + fromIntegral a `div` 2) `div` fromIntegral a :: Int)
+
+sharpen :: Int -> (Int, Int) -> VS.Vector Word8 -> VS.Vector Word8
+sharpen channels (w, h) samples = VS.create $ do
+  rows <- VSM.unsafeNew $ VS.length sharpenOffsets * stride
+  out <- VSM.unsafeNew $ VS.length samples
+  let blurRow r = forM_ [0 .. w - 1] $ \p -> do
+        let offsets
+              | p >= sharpenRadius && p < w - sharpenRadius = interior
+              | otherwise = VS.map (\t -> (max 0 (min (w - 1) (p + t)) - p) * channels) sharpenOffsets
+        forM_ [0 .. channels - 1] $ \c -> do
+          let i = (r * w + p) * channels + c
+          v <- convolve (\o -> pure $ fromIntegral $ VS.unsafeIndex samples $ i + o) offsets
+          VSM.unsafeWrite rows (rowStart r + p * channels + c) $ double2Float v
+  forM_ [0 .. min h sharpenRadius - 1] blurRow
+  forM_ [0 .. h - 1] $ \y -> do
+    when (y + sharpenRadius < h) $ blurRow $ y + sharpenRadius
+    let offsets = VS.map (\t -> rowStart $ max 0 $ min (h - 1) $ y + t) sharpenOffsets
+    forM_ [0 .. stride - 1] $ \x -> do
+      b <- convolve (\o -> float2Double <$> VSM.unsafeRead rows (o + x)) offsets
+      let i = y * stride + x
+      VSM.unsafeWrite out i $ unsharp (VS.unsafeIndex samples i) $ double2Float b
+  pure out
+  where
+    stride = channels * w
+    rowStart r = (r `mod` VS.length sharpenOffsets) * stride
+    interior = VS.map (* channels) sharpenOffsets
+    unsharp v b = fromIntegral (max 0 $ min 255 $ floor (fromIntegral v + sharpenAmount * float2Double (fromIntegral v - b) + 0.5) :: Int)
+
+convolve :: Monad m => (Int -> m Double) -> VS.Vector Int -> m Double
+convolve sample offsets = go 0 0
+  where
+    go t s
+      | t == VS.length sharpenWeights = pure s
+      | otherwise = sample (VS.unsafeIndex offsets t) >>= \v -> go (t + 1) (s + VS.unsafeIndex sharpenWeights t * v)
+{-# INLINE convolve #-}
+
+sharpenOffsets :: VS.Vector Int
+sharpenOffsets = VS.enumFromTo (-radius) radius
+  where
+    radius = ceiling (3 * sharpenSigma)
+
+sharpenWeights :: VS.Vector Double
+sharpenWeights = VS.map (/ VS.sum weights) weights
+  where
+    weights = VS.map (\t -> let d = fromIntegral t in exp (negate d * d / (2 * sharpenSigma * sharpenSigma))) sharpenOffsets
+
+sharpenRadius :: Int
+sharpenRadius = VS.last sharpenOffsets
+
+sharpenAmount :: Double
+sharpenAmount = 0.5
+
+sharpenSigma :: Double
+sharpenSigma = 0.6
+
+scaledSide :: Float -> Int -> Int
+scaledSide scale side = round $ fromIntegral side / scale
+
+toDataUri :: ImageFormat -> LB.ByteString -> LB.ByteString
+toDataUri format body = "data:image/" <> mime <> ";base64," <> LB64.encode body
+  where
+    mime = case format of
+      -- iOS and Android apps decode only the "jpg" mime type
+      IFJpeg -> "jpg"
+      IFPng -> "png"

src/Simplex/Chat/Library/Commands.hs

@@ -71,6 +71,7 @@ import Simplex.Chat.Call
 import Simplex.Chat.Controller
 import Simplex.Chat.Delivery (DeliveryJobScope (..), DeliveryJobSpec (..), DeliveryWorkerScope (..))
 import Simplex.Chat.Files
+import Simplex.Chat.Image (decodeResizable, resizeImageDataUri)
 import Simplex.Chat.Markdown
 import Simplex.Chat.Messages
 import Simplex.Chat.Messages.Batch (BatchMode, encodeBatchElement)
@@ -174,6 +175,9 @@ maxImageSize = 261120 * 2 -- auto-receive on mobiles
 maxProfileImageSize :: Int
 maxProfileImageSize = 12500
 
+maxImagePreviewSize :: Int64
+maxImagePreviewSize = 14000
+
 checkProfileImageSize :: Maybe ImageData -> CM ()
 checkProfileImageSize = mapM_ $ \(ImageData t) ->
   let size = T.length t
@@ -224,6 +228,14 @@ readProfileImageFile path = liftIO (loadImageData path) >>= either throwCmdError
 fixedImagePreview :: ImageData
 fixedImagePreview = ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAEAAAABACAYAAACqaXHeAAAAAXNSR0IArs4c6QAAAKVJREFUeF7t1kENACEUQ0FQhnVQ9lfGO+xggITQdvbMzArPey+8fa3tAfwAEdABZQspQStgBssEcgAIkSAJkiAJljtEgiRIgmUCSZAESZAESZAEyx0iQRIkwTKBJEiCv5fgvTd1wDmn7QAP4AeIgA4oW0gJWgEzWCZwbQ7gAA7ggLKFOIADOKBMIAeAEAmSIAmSYLlDJEiCJFgmkARJkARJ8N8S/ADTZUewBvnTOQAAAABJRU5ErkJggg=="
 
+imagePreview :: CryptoFile -> IO ImageData
+imagePreview f = either (const fixedImagePreview) (ImageData . safeDecodeUtf8 . LB.toStrict) <$> (runExceptT preview `catchAll` (pure . Left . show))
+  where
+    preview = do
+      s <- withExceptT show $ CF.readFile f
+      (img, profile) <- ExceptT $ decodeResizable $ LB.toStrict s
+      ExceptT $ resizeImageDataUri maxImagePreviewSize img profile
+
 imageFilePrefix :: String
 imageFilePrefix = "IMG_"
 
@@ -3547,8 +3559,8 @@ processChatCommand cxt nm = \case
       unless (any (`isSuffixOf` map toLower fPath) imageExtensions) $ throwChatError CEFileImageType {filePath}
       fileSize <- getFileSize filePath
       unless (fileSize <= maxImageSize) $ throwChatError CEFileImageSize {filePath}
-      -- TODO include file description for preview
-      processChatCommand cxt nm $ APISendMessages sendRef False Nothing False [composedMessage (Just f) (MCImage "" fixedImagePreview)]
+      preview <- liftIO $ imagePreview (f {filePath} :: CryptoFile)
+      processChatCommand cxt nm $ APISendMessages sendRef False Nothing False [composedMessage (Just f) (MCImage "" preview)]
   ForwardFile chatName fileId -> forwardFile chatName fileId SendFile
   ForwardImage chatName fileId -> forwardFile chatName fileId SendImage
   SendFileDescription _chatName _f -> throwCmdError "TODO"

src/Simplex/Chat/Mobile.hs

@@ -164,6 +164,18 @@ foreign export ccall "chat_encrypt_file" cChatEncryptFile :: StablePtr ChatContr
 
 foreign export ccall "chat_decrypt_file" cChatDecryptFile :: CString -> CString -> CString -> CString -> IO CString
 
+foreign export ccall "chat_resize_image_uri" cChatResizeImageUri :: Ptr Word8 -> CInt -> CInt -> IO CString
+
+foreign export ccall "chat_resize_image" cChatResizeImage :: Ptr Word8 -> CInt -> CInt -> CInt -> IO CString
+
+foreign export ccall "chat_resize_image_file_uri" cChatResizeImageFileUri :: CString -> CInt -> IO CString
+
+foreign export ccall "chat_resize_image_file" cChatResizeImageFile :: CString -> CInt -> CInt -> IO CString
+
+foreign export ccall "chat_resize_image_fd_uri" cChatResizeImageFdUri :: CInt -> CInt -> IO CString
+
+foreign export ccall "chat_resize_image_fd" cChatResizeImageFd :: CInt -> CInt -> CInt -> IO CString
+
 -- | check / migrate database and initialize chat controller on success
 -- For postgres first param is schema prefix, second param is database connection string.
 cChatMigrateInit :: CString -> CString -> CString -> Ptr (StablePtr ChatController) -> IO CJSONString

src/Simplex/Chat/Mobile/File.hs

@@ -10,6 +10,12 @@ module Simplex.Chat.Mobile.File
     cChatReadFile,
     cChatEncryptFile,
     cChatDecryptFile,
+    cChatResizeImageUri,
+    cChatResizeImage,
+    cChatResizeImageFileUri,
+    cChatResizeImageFile,
+    cChatResizeImageFdUri,
+    cChatResizeImageFd,
     WriteFileResult (..),
     ReadFileResult (..),
     chatWriteFile,
@@ -17,6 +23,7 @@ module Simplex.Chat.Mobile.File
   )
 where
 
+import Codec.Picture (DynamicImage)
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Class
@@ -24,6 +31,7 @@ import qualified Data.Aeson as J
 import qualified Data.Aeson.TH as JQ
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as B
+import qualified Data.ByteString.Base64.Lazy as LB64
 import qualified Data.ByteString.Lazy as LB
 import qualified Data.ByteString.Lazy.Char8 as LB'
 import Data.Char (chr)
@@ -34,7 +42,9 @@ import Foreign.Marshal.Alloc (mallocBytes)
 import Foreign.Ptr
 import Foreign.StablePtr
 import Foreign.Storable (poke, pokeByteOff)
+import GHC.IO.Handle.FD (fdToHandle)
 import Simplex.Chat.Controller (ChatController (..))
+import Simplex.Chat.Image (ColourProfile, ImageFormat (..), decodeResizable, imageFormat, maxDecodeMemoryMB, resizeImage, resizeImageDataUri)
 import Simplex.Chat.Mobile.Shared
 import Simplex.Chat.Util (chunkSize, encryptFile)
 import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..), CryptoFileHandle, FTCryptoError (..))
@@ -42,7 +52,8 @@ import qualified Simplex.Messaging.Crypto.File as CF
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
 import Simplex.Messaging.Util (catchAll)
-import UnliftIO (Handle, IOMode (..), atomically, withFile)
+import System.Posix.Internals (c_close)
+import UnliftIO (Handle, IOMode (..), atomically, bracket, hClose, hFileSize, onException, tryIO, withBinaryFile, withFile)
 
 data WriteFileResult
   = WFResult {cryptoArgs :: CryptoFileArgs}
@@ -139,6 +150,62 @@ chatDecryptFile fromPath keyStr nonceStr toPath = fromLeft "" <$> runCatchExcept
       liftIO $ B.hPut w ch
       when (size' > 0) $ decryptChunks r w size'
 
+cChatResizeImageUri :: Ptr Word8 -> CInt -> CInt -> IO CString
+cChatResizeImageUri ptr len = cResizeImageUri $ getByteString ptr len
+
+cChatResizeImage :: Ptr Word8 -> CInt -> CInt -> CInt -> IO CString
+cChatResizeImage ptr len = cResizeImageData $ getByteString ptr len
+
+cChatResizeImageFileUri :: CString -> CInt -> IO CString
+cChatResizeImageFileUri = cResizeImageUri . readFilePath
+
+cChatResizeImageFile :: CString -> CInt -> CInt -> IO CString
+cChatResizeImageFile = cResizeImageData . readFilePath
+
+cChatResizeImageFdUri :: CInt -> CInt -> IO CString
+cChatResizeImageFdUri = cResizeImageUri . readFd
+
+cChatResizeImageFd :: CInt -> CInt -> CInt -> IO CString
+cChatResizeImageFd = cResizeImageData . readFd
+
+readFilePath :: CString -> IO ByteString
+readFilePath cPath = do
+  path <- peekCString cPath
+  withBinaryFile path ReadMode hGetImage
+
+readFd :: CInt -> IO ByteString
+readFd fd = bracket (fdToHandle fd `onException` c_close fd) hClose hGetImage
+
+hGetImage :: Handle -> IO ByteString
+hGetImage h =
+  tryIO (hFileSize h) >>= \case
+    Right size
+      | size > fromIntegral maxSize -> tooLarge
+      | otherwise -> B.hGet h $ fromIntegral size
+    Left _ -> do
+      s <- LB.hGet h $ maxSize + 1
+      if LB.length s > fromIntegral maxSize then tooLarge else pure $ LB.toStrict s
+  where
+    maxSize = maxDecodeMemoryMB * 1048576
+    tooLarge = fail "image file is too large"
+
+cResizeImageUri :: IO ByteString -> CInt -> IO CString
+cResizeImageUri input maxSize = cResizeImage id (resizeImageDataUri $ fromIntegral maxSize) input
+
+cResizeImageData :: IO ByteString -> CInt -> CInt -> IO CString
+cResizeImageData input maxSize png = cResizeImage LB64.encode resize input
+  where
+    resize img = resizeImage (format img) (fromIntegral maxSize) img
+    format img = case compare png 0 of
+      LT -> imageFormat img
+      EQ -> IFJpeg
+      GT -> IFPng
+
+cResizeImage :: (LB.ByteString -> LB.ByteString) -> (DynamicImage -> ColourProfile -> IO (Either String LB.ByteString)) -> IO ByteString -> IO CString
+cResizeImage encode resize input = do
+  r <- runCatchExceptT $ ExceptT . uncurry resize =<< ExceptT (decodeResizable =<< input)
+  newCStringFromLazyBS $ either (const "") encode r
+
 runCatchExceptT :: ExceptT String IO a -> IO (Either String a)
 runCatchExceptT action = runExceptT action `catchAll` (pure . Left . show)
 

src/Simplex/Chat/Types.hs

@@ -950,7 +950,10 @@ instance ToJSON ImageData where
 
 safeImageData :: Text -> Text
 safeImageData t
-  | "data:" `T.isPrefixOf` t = t
+  | Just b64 <- T.stripPrefix "data:image/jpg;base64," t <|> T.stripPrefix "data:image/png;base64," t,
+    Right header <- B64.decode $ encodeUtf8 $ T.take 12 b64,
+    any (`B.isPrefixOf` header) ["\xFF\xD8\xFF", "\x89PNG\r\n\x1a\n"] =
+      t
   | otherwise = ""
 
 instance ToField ImageData where toField (ImageData t) = toField t