mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-05-24 15:15:35 +00:00
Add non-base64 resize and cWriteImage
This commit is contained in:
IC Rainbow
+37
-26
@@ -9,30 +9,33 @@
|
||||
|
||||
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.Metadata (Metadatas)
|
||||
import Codec.Picture.Png (encodePng)
|
||||
import qualified Codec.Picture.STBIR as STBIR
|
||||
import Codec.Picture.Types (dropAlphaLayer, pixelFoldMap)
|
||||
import Control.Monad.Except (ExceptT (..), runExceptT, throwError)
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Base64.Lazy as LB64
|
||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import Data.Int (Int64)
|
||||
import Data.Monoid (All(..))
|
||||
import Data.Monoid (All (..))
|
||||
import Data.Word (Word8)
|
||||
|
||||
resizeImageToStrSize :: Int64 -> ResizeableImage -> LB.ByteString
|
||||
resizeImageToStrSize maxSize (ResizeableImage fmt img encoder) = either resizePNG resizeJPG encoder
|
||||
resizeImageToSize :: Bool -> Int64 -> ResizeableImage -> LB.ByteString
|
||||
resizeImageToSize toURI maxSize (ResizeableImage fmt img encoder) = either resizePNG resizeJPG encoder
|
||||
where
|
||||
halveAndRetry = resizeImageToStrSize maxSize $ ResizeableImage fmt imgHalved encoder
|
||||
halveAndRetry = resizeImageToSize toURI maxSize $ ResizeableImage fmt imgHalved encoder
|
||||
imgHalved = downscale img 2.0
|
||||
resizePNG enc
|
||||
| LB.length encoded <= maxSize = encoded
|
||||
| LB.length (encode imgHalved) > maxSize = halveAndRetry
|
||||
| otherwise = fitScale 1.0 2.0
|
||||
where
|
||||
encode = toDataUri "png" enc
|
||||
encode
|
||||
| toURI = toDataUri "png" . enc
|
||||
| otherwise = enc
|
||||
encoded = encode img
|
||||
fitScale l u
|
||||
| u - l < 1 / 64 = encode $ downscale img u -- prefer lower resolution
|
||||
@@ -41,14 +44,16 @@ resizeImageToStrSize maxSize (ResizeableImage fmt img encoder) = either resizePN
|
||||
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
|
||||
where
|
||||
m = (l + u) / 2
|
||||
result = encode $ downscale img m
|
||||
resizeJPG enc
|
||||
| minSize > maxSize = halveAndRetry
|
||||
| otherwise = fitQuality 33 99
|
||||
where
|
||||
encode q = toDataUri "jpeg" (enc q) img
|
||||
encode q
|
||||
| toURI = toDataUri "jpeg" $ enc q img
|
||||
| otherwise = enc q img
|
||||
minSize = LB.length $ encode 33
|
||||
fitQuality l u
|
||||
| u - l <= 1 = encode l -- prefer higher compression
|
||||
@@ -57,21 +62,26 @@ resizeImageToStrSize maxSize (ResizeableImage fmt img encoder) = either resizePN
|
||||
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
|
||||
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)
|
||||
toDataUri :: LB.ByteString -> LB.ByteString -> LB.ByteString
|
||||
toDataUri fmt body = "data:image/" <> fmt <> ";base64," <> LB64.encode body
|
||||
|
||||
decodeResizeable :: ByteString -> Either String (ResizeableImage, Metadatas)
|
||||
decodeResizeable source = do
|
||||
(input, metadata) <- Picture.decodeImageWithMetadata source
|
||||
maybe (Left "unsupported image format") (pure . (,metadata)) $ resizeableImage (tryDropOpacity input)
|
||||
|
||||
readResizeable :: FilePath -> IO (Either String (ResizeableImage, Metadatas))
|
||||
readResizeable inputPath = runExceptT $ do
|
||||
(input, metadata) <- ExceptT $ Picture.readImageWithMetadata inputPath
|
||||
(input, metadata) <- ExceptT $ Picture.readImageWithMetadata inputPath -- will use mmap instead of reading the whole file
|
||||
maybe (throwError "unsupported image format") (pure . (,metadata)) $ resizeableImage (tryDropOpacity input)
|
||||
|
||||
tryDropOpacity :: Picture.DynamicImage -> Picture.DynamicImage
|
||||
@@ -86,12 +96,14 @@ tryDropOpacity dyn = case dyn of
|
||||
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
|
||||
ResizeableImage ::
|
||||
STBIR.STBIRPixel a =>
|
||||
-- | format label
|
||||
String ->
|
||||
-- | current image data
|
||||
Picture.Image a ->
|
||||
ImageEncoder a ->
|
||||
ResizeableImage
|
||||
|
||||
type ImageEncoder a = Either (PNGEncoder a) (JPGEncoder a)
|
||||
type PNGEncoder a = Picture.Image a -> LB.ByteString
|
||||
@@ -113,4 +125,3 @@ resizeableImage dyn = case dyn of
|
||||
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.
|
||||
|
||||
@@ -30,14 +30,14 @@ import Data.Word (Word8)
|
||||
import Database.SQLite.Simple (SQLError (..))
|
||||
import qualified Database.SQLite.Simple as DB
|
||||
import Foreign.C.String
|
||||
import Foreign.C.Types (CInt (..))
|
||||
import Foreign.C.Types (CInt (..), CLong (..))
|
||||
import Foreign.Ptr
|
||||
import Foreign.StablePtr
|
||||
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.Image (readResizeable, resizeImageToSize)
|
||||
import Simplex.Chat.Markdown (ParsedMarkdown (..), parseMaybeMarkdownList)
|
||||
import Simplex.Chat.Mobile.File
|
||||
import Simplex.Chat.Mobile.Shared
|
||||
@@ -105,6 +105,8 @@ foreign export ccall "chat_decrypt_media" cChatDecryptMedia :: CString -> Ptr Wo
|
||||
|
||||
foreign export ccall "chat_write_file" cChatWriteFile :: StablePtr ChatController -> CString -> Ptr Word8 -> CInt -> IO CJSONString
|
||||
|
||||
foreign export ccall "chat_write_image" cChatWriteImage :: StablePtr ChatController -> CLong -> CString -> Ptr Word8 -> CInt -> IO CJSONString
|
||||
|
||||
foreign export ccall "chat_read_file" cChatReadFile :: CString -> CString -> CString -> IO (Ptr Word8)
|
||||
|
||||
foreign export ccall "chat_encrypt_file" cChatEncryptFile :: StablePtr ChatController -> CString -> CString -> IO CJSONString
|
||||
@@ -208,7 +210,7 @@ cChatResizeImageToStrSize fp' maxSize = do
|
||||
fp <- peekCString fp'
|
||||
res <- runExceptT $ do
|
||||
(ri, _) <- liftIOEither $ readResizeable fp
|
||||
let resized = resizeImageToStrSize (fromIntegral maxSize) ri
|
||||
let resized = resizeImageToSize True (fromIntegral maxSize) ri
|
||||
if LB.length resized > fromIntegral maxSize then throwError "unable to fit" else pure resized
|
||||
newCStringFromLazyBS $ fromRight "" res
|
||||
|
||||
|
||||
@@ -7,6 +7,7 @@
|
||||
|
||||
module Simplex.Chat.Mobile.File
|
||||
( cChatWriteFile,
|
||||
cChatWriteImage,
|
||||
cChatReadFile,
|
||||
cChatEncryptFile,
|
||||
cChatDecryptFile,
|
||||
@@ -35,6 +36,8 @@ import Foreign.Ptr
|
||||
import Foreign.StablePtr
|
||||
import Foreign.Storable (poke, pokeByteOff)
|
||||
import Simplex.Chat.Controller (ChatController (..))
|
||||
import Simplex.Chat.Image (resizeImageToSize)
|
||||
import qualified Simplex.Chat.Image as Picture
|
||||
import Simplex.Chat.Mobile.Shared
|
||||
import Simplex.Chat.Util (chunkSize, encryptFile)
|
||||
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..), CryptoFileHandle, FTCryptoError (..))
|
||||
@@ -58,6 +61,21 @@ cChatWriteFile cc cPath ptr len = do
|
||||
r <- chatWriteFile c path s
|
||||
newCStringFromLazyBS $ J.encode r
|
||||
|
||||
cChatWriteImage :: StablePtr ChatController -> CLong -> CString -> Ptr Word8 -> CInt -> IO CJSONString
|
||||
cChatWriteImage cc maxSize cPath ptr len = do
|
||||
c <- deRefStablePtr cc
|
||||
path <- peekCString cPath
|
||||
src <- getByteString ptr len
|
||||
r <-
|
||||
case Picture.decodeResizeable src of
|
||||
Left e -> pure $ WFError e
|
||||
Right (ri, _metadata) -> do
|
||||
let resized = resizeImageToSize True (fromIntegral maxSize) ri
|
||||
if LB.length resized > fromIntegral maxSize
|
||||
then pure $ WFError "unable to fit"
|
||||
else chatWriteFile c path (LB.toStrict resized)
|
||||
newCStringFromLazyBS $ J.encode r
|
||||
|
||||
chatWriteFile :: ChatController -> FilePath -> ByteString -> IO WriteFileResult
|
||||
chatWriteFile ChatController {random} path s = do
|
||||
cfArgs <- atomically $ CF.randomArgs random
|
||||
|
||||
Reference in New Issue
Block a user