From b3e880ee542acdde58f6eb79baf976b83e0c4bc8 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Fri, 22 Sep 2023 13:45:16 +0100 Subject: [PATCH] core: optimize C apis (#3100) * core: optimize C apis * more * fix tests * use pokeByteOff * write lazy bytestring to buffer without conversion to strict * avoid conversion of JSON to strict bytestrings --- src/Simplex/Chat/Mobile.hs | 48 +++++++++++++++---------------- src/Simplex/Chat/Mobile/File.hs | 15 +++++----- src/Simplex/Chat/Mobile/Shared.hs | 43 ++++++++++++++++++++++----- src/Simplex/Chat/Types.hs | 2 -- tests/MobileTests.hs | 21 +++++++------- 5 files changed, 77 insertions(+), 52 deletions(-) diff --git a/src/Simplex/Chat/Mobile.hs b/src/Simplex/Chat/Mobile.hs index 57113dea6..700548bb1 100644 --- a/src/Simplex/Chat/Mobile.hs +++ b/src/Simplex/Chat/Mobile.hs @@ -14,14 +14,12 @@ import Data.Aeson (ToJSON (..)) import qualified Data.Aeson as J import Data.Bifunctor (first) import qualified Data.ByteString.Base64.URL as U +import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy.Char8 as LB import Data.Functor (($>)) import Data.List (find) import qualified Data.List.NonEmpty as L import Data.Maybe (fromMaybe) -import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) import Data.Word (Word8) import Database.SQLite.Simple (SQLError (..)) import qualified Database.SQLite.Simple as DB @@ -95,36 +93,36 @@ cChatMigrateInit fp key conf ctrl = do chatMigrateInit dbPath dbKey confirm >>= \case Right cc -> (newStablePtr cc >>= poke ctrl) $> DBMOk Left e -> pure e - newCAString . LB.unpack $ J.encode r + newCStringFromLazyBS $ J.encode r -- | send command to chat (same syntax as in terminal for now) cChatSendCmd :: StablePtr ChatController -> CString -> IO CJSONString cChatSendCmd cPtr cCmd = do c <- deRefStablePtr cPtr - cmd <- peekCAString cCmd - newCAString =<< chatSendCmd c cmd + cmd <- B.packCString cCmd + newCStringFromLazyBS =<< chatSendCmd c cmd -- | receive message from chat (blocking) cChatRecvMsg :: StablePtr ChatController -> IO CJSONString -cChatRecvMsg cc = deRefStablePtr cc >>= chatRecvMsg >>= newCAString +cChatRecvMsg cc = deRefStablePtr cc >>= chatRecvMsg >>= newCStringFromLazyBS -- | receive message from chat (blocking up to `t` microseconds (1/10^6 sec), returns empty string if times out) cChatRecvMsgWait :: StablePtr ChatController -> CInt -> IO CJSONString -cChatRecvMsgWait cc t = deRefStablePtr cc >>= (`chatRecvMsgWait` fromIntegral t) >>= newCAString +cChatRecvMsgWait cc t = deRefStablePtr cc >>= (`chatRecvMsgWait` fromIntegral t) >>= newCStringFromLazyBS -- | parse markdown - returns ParsedMarkdown type JSON cChatParseMarkdown :: CString -> IO CJSONString -cChatParseMarkdown s = newCAString . chatParseMarkdown =<< peekCAString s +cChatParseMarkdown s = newCStringFromLazyBS . chatParseMarkdown =<< B.packCString s -- | parse server address - returns ParsedServerAddress JSON cChatParseServer :: CString -> IO CJSONString -cChatParseServer s = newCAString . chatParseServer =<< peekCAString s +cChatParseServer s = newCStringFromLazyBS . chatParseServer =<< B.packCString s cChatPasswordHash :: CString -> CString -> IO CString cChatPasswordHash cPwd cSalt = do - pwd <- peekCAString cPwd - salt <- peekCAString cSalt - newCAString $ chatPasswordHash pwd salt + pwd <- B.packCString cPwd + salt <- B.packCString cSalt + newCStringFromBS $ chatPasswordHash pwd salt mobileChatOpts :: String -> String -> ChatOpts mobileChatOpts dbFilePrefix dbKey = @@ -197,22 +195,22 @@ chatMigrateInit dbFilePrefix dbKey confirm = runExceptT $ do _ -> dbError e dbError e = Left . DBMErrorSQL dbFile $ show e -chatSendCmd :: ChatController -> String -> IO JSONString -chatSendCmd cc s = LB.unpack . J.encode . APIResponse Nothing <$> runReaderT (execChatCommand $ B.pack s) cc +chatSendCmd :: ChatController -> ByteString -> IO JSONByteString +chatSendCmd cc s = J.encode . APIResponse Nothing <$> runReaderT (execChatCommand s) cc -chatRecvMsg :: ChatController -> IO JSONString +chatRecvMsg :: ChatController -> IO JSONByteString chatRecvMsg ChatController {outputQ} = json <$> atomically (readTBQueue outputQ) where - json (corr, resp) = LB.unpack $ J.encode APIResponse {corr, resp} + json (corr, resp) = J.encode APIResponse {corr, resp} -chatRecvMsgWait :: ChatController -> Int -> IO JSONString +chatRecvMsgWait :: ChatController -> Int -> IO JSONByteString chatRecvMsgWait cc time = fromMaybe "" <$> timeout time (chatRecvMsg cc) -chatParseMarkdown :: String -> JSONString -chatParseMarkdown = LB.unpack . J.encode . ParsedMarkdown . parseMaybeMarkdownList . safeDecodeUtf8 . B.pack +chatParseMarkdown :: ByteString -> JSONByteString +chatParseMarkdown = J.encode . ParsedMarkdown . parseMaybeMarkdownList . safeDecodeUtf8 -chatParseServer :: String -> JSONString -chatParseServer = LB.unpack . J.encode . toServerAddress . strDecode . B.pack +chatParseServer :: ByteString -> JSONByteString +chatParseServer = J.encode . toServerAddress . strDecode where toServerAddress :: Either String AProtoServerWithAuth -> ParsedServerAddress toServerAddress = \case @@ -223,11 +221,11 @@ chatParseServer = LB.unpack . J.encode . toServerAddress . strDecode . B.pack enc :: StrEncoding a => a -> String enc = B.unpack . strEncode -chatPasswordHash :: String -> String -> String +chatPasswordHash :: ByteString -> ByteString -> ByteString chatPasswordHash pwd salt = either (const "") passwordHash salt' where - salt' = U.decode $ B.pack salt - passwordHash = B.unpack . U.encode . C.sha512Hash . (encodeUtf8 (T.pack pwd) <>) + salt' = U.decode salt + passwordHash = U.encode . C.sha512Hash . (pwd <>) data APIResponse = APIResponse {corr :: Maybe CorrId, resp :: ChatResponse} deriving (Generic) diff --git a/src/Simplex/Chat/Mobile/File.hs b/src/Simplex/Chat/Mobile/File.hs index e30b899f1..73978549f 100644 --- a/src/Simplex/Chat/Mobile/File.hs +++ b/src/Simplex/Chat/Mobile/File.hs @@ -27,11 +27,11 @@ import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString.Lazy.Char8 as LB' import Data.Char (chr) import Data.Either (fromLeft) -import Data.Word (Word8, Word32) +import Data.Word (Word32, Word8) import Foreign.C import Foreign.Marshal.Alloc (mallocBytes) import Foreign.Ptr -import Foreign.Storable (poke) +import Foreign.Storable (poke, pokeByteOff) import GHC.Generics (Generic) import Simplex.Chat.Mobile.Shared import Simplex.Chat.Util (chunkSize, encryptFile) @@ -54,7 +54,7 @@ cChatWriteFile cPath ptr len = do path <- peekCString cPath s <- getByteString ptr len r <- chatWriteFile path s - newCAString $ LB'.unpack $ J.encode r + newCStringFromLazyBS $ J.encode r chatWriteFile :: FilePath -> ByteString -> IO WriteFileResult chatWriteFile path s = do @@ -78,12 +78,11 @@ cChatReadFile cPath cKey cNonce = do chatReadFile path key nonce >>= \case Left e -> castPtr <$> newCString (chr 1 : e) Right s -> do - let s' = LB.toStrict s - len = B.length s' + let len = fromIntegral $ LB.length s ptr <- mallocBytes $ len + 5 - poke ptr 0 - poke (ptr `plusPtr` 1) (fromIntegral len :: Word32) - putByteString (ptr `plusPtr` 5) s' + poke ptr (0 :: Word8) + pokeByteOff ptr 1 (fromIntegral len :: Word32) + putLazyByteString (ptr `plusPtr` 5) s pure ptr chatReadFile :: FilePath -> ByteString -> ByteString -> IO (Either String LB.ByteString) diff --git a/src/Simplex/Chat/Mobile/Shared.hs b/src/Simplex/Chat/Mobile/Shared.hs index a73a25fb6..d0c5b0b86 100644 --- a/src/Simplex/Chat/Mobile/Shared.hs +++ b/src/Simplex/Chat/Mobile/Shared.hs @@ -1,19 +1,48 @@ +{-# LANGUAGE LambdaCase #-} + module Simplex.Chat.Mobile.Shared where import qualified Data.ByteString as B -import Data.ByteString.Internal (ByteString (PS), memcpy) +import Data.ByteString.Internal (ByteString (..), memcpy) +import qualified Data.ByteString.Lazy as LB +import qualified Data.ByteString.Lazy.Internal as LB import Foreign.C (CInt, CString) -import Foreign (Ptr, Word8, newForeignPtr_, plusPtr) -import Foreign.ForeignPtr.Unsafe +import Foreign type CJSONString = CString +type JSONByteString = LB.ByteString + getByteString :: Ptr Word8 -> CInt -> IO ByteString getByteString ptr len = do fp <- newForeignPtr_ ptr - pure $ PS fp 0 $ fromIntegral len + pure $ BS fp $ fromIntegral len +{-# INLINE getByteString #-} putByteString :: Ptr Word8 -> ByteString -> IO () -putByteString ptr bs@(PS fp offset _) = do - let p = unsafeForeignPtrToPtr fp `plusPtr` offset - memcpy ptr p $ B.length bs +putByteString ptr (BS fp len) = + withForeignPtr fp $ \p -> memcpy ptr p len +{-# INLINE putByteString #-} + +putLazyByteString :: Ptr Word8 -> LB.ByteString -> IO () +putLazyByteString ptr = \case + LB.Empty -> pure () + LB.Chunk ch s -> do + putByteString ptr ch + putLazyByteString (ptr `plusPtr` B.length ch) s + +newCStringFromBS :: ByteString -> IO CString +newCStringFromBS s = do + let len = B.length s + buf <- mallocBytes (len + 1) + putByteString buf s + pokeByteOff buf len (0 :: Word8) + pure $ castPtr buf + +newCStringFromLazyBS :: LB.ByteString -> IO CString +newCStringFromLazyBS s = do + let len = fromIntegral $ LB.length s + buf <- mallocBytes (len + 1) + putLazyByteString buf s + pokeByteOff buf len (0 :: Word8) + pure $ castPtr buf diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index ecae9eb09..93964316c 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -1393,8 +1393,6 @@ serializeIntroStatus = \case data Notification = Notification {title :: Text, text :: Text} -type JSONString = String - textParseJSON :: TextEncoding a => String -> J.Value -> JT.Parser a textParseJSON name = J.withText name $ maybe (fail $ "bad " <> name) pure . textDecode diff --git a/tests/MobileTests.hs b/tests/MobileTests.hs index 07d0d2fe9..0b965250b 100644 --- a/tests/MobileTests.hs +++ b/tests/MobileTests.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -61,66 +62,66 @@ mobileTests = do it "utf8 name 2" $ testFileEncryptionCApi "👍" it "no exception on missing file" testMissingFileEncryptionCApi -noActiveUser :: String +noActiveUser :: LB.ByteString #if defined(darwin_HOST_OS) && defined(swiftJSON) noActiveUser = "{\"resp\":{\"chatCmdError\":{\"chatError\":{\"error\":{\"errorType\":{\"noActiveUser\":{}}}}}}}" #else noActiveUser = "{\"resp\":{\"type\":\"chatCmdError\",\"chatError\":{\"type\":\"error\",\"errorType\":{\"type\":\"noActiveUser\"}}}}" #endif -activeUserExists :: String +activeUserExists :: LB.ByteString #if defined(darwin_HOST_OS) && defined(swiftJSON) activeUserExists = "{\"resp\":{\"chatCmdError\":{\"user_\":{\"userId\":1,\"agentUserId\":\"1\",\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"Alice\",\"localAlias\":\"\"},\"fullPreferences\":{\"timedMessages\":{\"allow\":\"yes\"},\"fullDelete\":{\"allow\":\"no\"},\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"},\"calls\":{\"allow\":\"yes\"}},\"activeUser\":true,\"showNtfs\":true,\"sendRcptsContacts\":true,\"sendRcptsSmallGroups\":true},\"chatError\":{\"error\":{\"errorType\":{\"userExists\":{\"contactName\":\"alice\"}}}}}}}" #else activeUserExists = "{\"resp\":{\"type\":\"chatCmdError\",\"user_\":{\"userId\":1,\"agentUserId\":\"1\",\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"Alice\",\"localAlias\":\"\"},\"fullPreferences\":{\"timedMessages\":{\"allow\":\"yes\"},\"fullDelete\":{\"allow\":\"no\"},\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"},\"calls\":{\"allow\":\"yes\"}},\"activeUser\":true,\"showNtfs\":true,\"sendRcptsContacts\":true,\"sendRcptsSmallGroups\":true},\"chatError\":{\"type\":\"error\",\"errorType\":{\"type\":\"userExists\",\"contactName\":\"alice\"}}}}" #endif -activeUser :: String +activeUser :: LB.ByteString #if defined(darwin_HOST_OS) && defined(swiftJSON) activeUser = "{\"resp\":{\"activeUser\":{\"user\":{\"userId\":1,\"agentUserId\":\"1\",\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"Alice\",\"localAlias\":\"\"},\"fullPreferences\":{\"timedMessages\":{\"allow\":\"yes\"},\"fullDelete\":{\"allow\":\"no\"},\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"},\"calls\":{\"allow\":\"yes\"}},\"activeUser\":true,\"showNtfs\":true,\"sendRcptsContacts\":true,\"sendRcptsSmallGroups\":true}}}}" #else activeUser = "{\"resp\":{\"type\":\"activeUser\",\"user\":{\"userId\":1,\"agentUserId\":\"1\",\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"Alice\",\"localAlias\":\"\"},\"fullPreferences\":{\"timedMessages\":{\"allow\":\"yes\"},\"fullDelete\":{\"allow\":\"no\"},\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"},\"calls\":{\"allow\":\"yes\"}},\"activeUser\":true,\"showNtfs\":true,\"sendRcptsContacts\":true,\"sendRcptsSmallGroups\":true}}}" #endif -chatStarted :: String +chatStarted :: LB.ByteString #if defined(darwin_HOST_OS) && defined(swiftJSON) chatStarted = "{\"resp\":{\"chatStarted\":{}}}" #else chatStarted = "{\"resp\":{\"type\":\"chatStarted\"}}" #endif -contactSubSummary :: String +contactSubSummary :: LB.ByteString #if defined(darwin_HOST_OS) && defined(swiftJSON) contactSubSummary = "{\"resp\":{\"contactSubSummary\":{" <> userJSON <> ",\"contactSubscriptions\":[]}}}" #else contactSubSummary = "{\"resp\":{\"type\":\"contactSubSummary\"," <> userJSON <> ",\"contactSubscriptions\":[]}}" #endif -memberSubSummary :: String +memberSubSummary :: LB.ByteString #if defined(darwin_HOST_OS) && defined(swiftJSON) memberSubSummary = "{\"resp\":{\"memberSubSummary\":{" <> userJSON <> ",\"memberSubscriptions\":[]}}}" #else memberSubSummary = "{\"resp\":{\"type\":\"memberSubSummary\"," <> userJSON <> ",\"memberSubscriptions\":[]}}" #endif -userContactSubSummary :: String +userContactSubSummary :: LB.ByteString #if defined(darwin_HOST_OS) && defined(swiftJSON) userContactSubSummary = "{\"resp\":{\"userContactSubSummary\":{" <> userJSON <> ",\"userContactSubscriptions\":[]}}}" #else userContactSubSummary = "{\"resp\":{\"type\":\"userContactSubSummary\"," <> userJSON <> ",\"userContactSubscriptions\":[]}}" #endif -pendingSubSummary :: String +pendingSubSummary :: LB.ByteString #if defined(darwin_HOST_OS) && defined(swiftJSON) pendingSubSummary = "{\"resp\":{\"pendingSubSummary\":{" <> userJSON <> ",\"pendingSubscriptions\":[]}}}" #else pendingSubSummary = "{\"resp\":{\"type\":\"pendingSubSummary\"," <> userJSON <> ",\"pendingSubscriptions\":[]}}" #endif -userJSON :: String +userJSON :: LB.ByteString userJSON = "\"user\":{\"userId\":1,\"agentUserId\":\"1\",\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"Alice\",\"localAlias\":\"\"},\"fullPreferences\":{\"timedMessages\":{\"allow\":\"yes\"},\"fullDelete\":{\"allow\":\"no\"},\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"},\"calls\":{\"allow\":\"yes\"}},\"activeUser\":true,\"showNtfs\":true,\"sendRcptsContacts\":true,\"sendRcptsSmallGroups\":true}" -parsedMarkdown :: String +parsedMarkdown :: LB.ByteString #if defined(darwin_HOST_OS) && defined(swiftJSON) parsedMarkdown = "{\"formattedText\":[{\"format\":{\"bold\":{}},\"text\":\"hello\"}]}" #else