From 8bfff48f94eb38df048e32fd64afbdd010080939 Mon Sep 17 00:00:00 2001 From: IC Rainbow Date: Sun, 20 Oct 2024 13:25:49 +0300 Subject: [PATCH] WIP: add FFI export wrapper --- apps/ios/SimpleXChat/SimpleX.h | 1 + flake.nix | 2 ++ libsimplex.dll.def | 3 ++- src/Simplex/Chat/Image.hs | 22 +++++++++++++--------- src/Simplex/Chat/Mobile.hs | 30 ++++++++++++++++++++++++++++++ tests/LinkPreviewTests.hs | 26 +++++++++++--------------- 6 files changed, 59 insertions(+), 25 deletions(-) diff --git a/apps/ios/SimpleXChat/SimpleX.h b/apps/ios/SimpleXChat/SimpleX.h index 92dfafca21..cb94477a33 100644 --- a/apps/ios/SimpleXChat/SimpleX.h +++ b/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); diff --git a/flake.nix b/flake.nix index e8ff779a87..45b4d2b0a7 100644 --- a/flake.nix +++ b/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 diff --git a/libsimplex.dll.def b/libsimplex.dll.def index 592e6db4f2..75d89498ef 100644 --- a/libsimplex.dll.def +++ b/libsimplex.dll.def @@ -18,4 +18,5 @@ EXPORTS chat_write_file chat_read_file chat_encrypt_file - chat_decrypt_file \ No newline at end of file + chat_decrypt_file + chat_resize_image_to_str_size \ No newline at end of file diff --git a/src/Simplex/Chat/Image.hs b/src/Simplex/Chat/Image.hs index 9715f0a2a6..0677462cf1 100644 --- a/src/Simplex/Chat/Image.hs +++ b/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 diff --git a/src/Simplex/Chat/Mobile.hs b/src/Simplex/Chat/Mobile.hs index 57b0ee6c17..5d55b21fa6 100644 --- a/src/Simplex/Chat/Mobile.hs +++ b/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 diff --git a/tests/LinkPreviewTests.hs b/tests/LinkPreviewTests.hs index 7fb05294fe..4dc26d7980 100644 --- a/tests/LinkPreviewTests.hs +++ b/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