WIP: add FFI export wrapper

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