WIP: add FFI export wrapper

apps/ios/SimpleXChat/SimpleX.h

@@ -29,6 +29,7 @@ extern char *chat_valid_name(char *name);
 extern int chat_json_length(char *str);
 extern char *chat_encrypt_media(chat_ctrl ctl, char *key, char *frame, int len);
 extern char *chat_decrypt_media(char *key, char *frame, int len);
+extern char *chat_resize_image_to_str_size(char *path, int maxSize);
 
 // chat_write_file returns null-terminated string with JSON of WriteFileResult
 extern char *chat_write_file(chat_ctrl ctl, char *path, char *data, int len);

flake.nix

@@ -387,6 +387,7 @@
                   "chat_valid_name"
                   "chat_json_length"
                   "chat_write_file"
+                  "chat_resize_image_to_str_size"
                 ];
                 postInstall = ''
                   set -x
@@ -490,6 +491,7 @@
                   "chat_valid_name"
                   "chat_json_length"
                   "chat_write_file"
+                  "chat_resize_image_to_str_size"
                 ];
                 postInstall = ''
                   set -x

libsimplex.dll.def

@@ -18,4 +18,5 @@ EXPORTS
     chat_write_file
     chat_read_file
     chat_encrypt_file
-    chat_decrypt_file
+    chat_decrypt_file
+    chat_resize_image_to_str_size

src/Simplex/Chat/Image.hs

@@ -2,18 +2,18 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 
 module Simplex.Chat.Image where
 
 import qualified Data.ByteString.Base64.Lazy as LB64
 import qualified Data.ByteString.Lazy.Char8 as LB
+import Control.Monad.Except (ExceptT (..), runExceptT, throwError)
 import qualified Codec.Picture as Picture
+import Codec.Picture.Metadata (Metadatas)
 import Codec.Picture.Jpg (encodeDirectJpegAtQualityWithMetadata)
 import Codec.Picture.Png (encodePng)
 import qualified Codec.Picture.STBIR as STBIR
@@ -22,15 +22,15 @@ import Data.Int (Int64)
 import Data.Monoid (All(..))
 import Data.Word (Word8)
 
-resizeImageToStrSize :: Int64 -> ResizeableImage -> Maybe LB.ByteString
+resizeImageToStrSize :: Int64 -> ResizeableImage -> 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 encoded <= maxSize = encoded
       | LB.length (encode imgHalved) > maxSize = halveAndRetry
-      | otherwise = Just $ fitScale 1.0 2.0
+      | otherwise = fitScale 1.0 2.0
       where
         encode = toDataUri "png" enc
         encoded = encode img
@@ -44,13 +44,12 @@ resizeImageToStrSize maxSize (ResizeableImage fmt img encoder) = either resizePN
               where
                 m = (l + u) / 2
                 result = encode $ downscale img m
-    resizeJPG enc -- if minSize > maxSize then halveAndRetry else Just $ fitQuality 33 99
+    resizeJPG enc
       | minSize > maxSize = halveAndRetry
-      | otherwise = Just $ fitQuality 33 99
+      | otherwise = 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 =
@@ -70,6 +69,11 @@ downscale img scale = STBIR.resize STBIR.defaultOptions (scaled Picture.imageWid
 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)
 
+readResizeable :: FilePath -> IO (Either String (ResizeableImage, Metadatas))
+readResizeable inputPath = runExceptT $ do
+  (input, metadata) <- ExceptT $ Picture.readImageWithMetadata inputPath
+  maybe (throwError "unsupported image format") (pure . (,metadata)) $ resizeableImage (tryDropOpacity input)
+
 tryDropOpacity :: Picture.DynamicImage -> Picture.DynamicImage
 tryDropOpacity dyn = case dyn of
   Picture.ImageRGBA16 img | opaque img -> Picture.ImageRGB16 $ dropAlphaLayer img

src/Simplex/Chat/Mobile.hs

@@ -36,6 +36,7 @@ import Foreign.Storable (poke)
 import GHC.IO.Encoding (setFileSystemEncoding, setForeignEncoding, setLocaleEncoding)
 import Simplex.Chat
 import Simplex.Chat.Controller
+import Simplex.Chat.Image (readResizeable, resizeImageToStrSize)
 import Simplex.Chat.Markdown (ParsedMarkdown (..), parseMaybeMarkdownList)
 import Simplex.Chat.Mobile.File
 import Simplex.Chat.Mobile.Shared
@@ -45,6 +46,7 @@ import Simplex.Chat.Remote.Types
 import Simplex.Chat.Store
 import Simplex.Chat.Store.Profiles
 import Simplex.Chat.Types
+import Simplex.Chat.Util (liftIOEither)
 import Simplex.Messaging.Agent.Client (agentClientStore)
 import Simplex.Messaging.Agent.Env.SQLite (createAgentStore)
 import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), MigrationError, closeSQLiteStore, reopenSQLiteStore)
@@ -108,6 +110,8 @@ 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_to_str_size" cChatResizeImageToStrSize :: CString -> CInt -> IO CString
+
 -- | check / migrate database and initialize chat controller on success
 cChatMigrateInit :: CString -> CString -> CString -> Ptr (StablePtr ChatController) -> IO CJSONString
 cChatMigrateInit fp key conf = cChatMigrateInitKey fp key 0 conf 0
@@ -182,6 +186,32 @@ cChatValidName cName = newCString . mkValidName =<< peekCString cName
 cChatJsonLength :: CString -> IO CInt
 cChatJsonLength s = fromIntegral . subtract 2 . LB.length . J.encode . safeDecodeUtf8 <$> B.packCString s
 
+-- -- | Resize image at path to match specified dimensions preserving aspect ratio
+-- cChatResizeImageToFit :: CString -> CInt -> CInt -> IO CString
+-- cChatResizeImageToFit path maxWidth maxHeight = error "todo"
+
+-- -- | Resize image at path to match specified dimensions, cropping the extra pixels
+-- cChatResizeImageCrop :: CString -> CInt -> CInt -> IO CString
+-- cChatResizeImageCrop path width height = error "todo" -- аватарки
+
+-- -- | Downscale image at path until it fits into specified size
+-- cChatResizeImageToDataSize :: CString -> CInt -> IO CString
+-- cChatResizeImageToDataSize path maxSize = error "todo"
+
+-- | Downscale image at path until its data-uri encoding fits into specified size
+cChatResizeImageToStrSize :: CString -> CInt -> IO CString
+cChatResizeImageToStrSize fp' maxSize = do
+  fp <- peekCString fp'
+  res <- runExceptT $ do
+    (ri, _) <- liftIOEither $ readResizeable fp
+    let resized = resizeImageToStrSize (fromIntegral maxSize) ri
+    if LB.length resized > fromIntegral maxSize then throwError "unable to fit" else pure resized
+  either (const $ pure nullPtr) newCStringFromLazyBS res
+
+-- -- | Strip EXIF etc metadata from image, inlplace
+-- cChatStripImageMetadata :: CString -> IO CBool
+-- cChatStripImageMetadata path = error "todo"
+
 mobileChatOpts :: String -> ChatOpts
 mobileChatOpts dbFilePrefix =
   ChatOpts

tests/LinkPreviewTests.hs

@@ -5,7 +5,8 @@ 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.Chat.Image (ResizeableImage (..))
+import qualified Simplex.Chat.Image as Image
 import Simplex.Messaging.Util (tshow)
 import Test.Hspec
 
@@ -18,19 +19,14 @@ linkPreviewTests = do
 
 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)
+  (ri@(ResizeableImage imgFormat _img encoder), metadata) <- either error pure =<< Image.readResizeable inputPath
+  logDebug $ tshow (metadata, imgFormat, either (const "png") (const "jpeg") encoder)
+  let res = Image.resizeImageToStrSize maxSize ri
+      finalSize = LB.length res
+  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 res
+      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