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

@@ -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
+  cmd <- B.packCString cCmd
-  newCAString =<< chatSendCmd c cmd
+  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
+  pwd <- B.packCString cPwd
-  salt <- peekCAString cSalt
+  salt <- B.packCString cSalt
-  newCAString $ chatPasswordHash pwd salt
+  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 :: ChatController -> ByteString -> IO JSONByteString
-chatSendCmd cc s = LB.unpack . J.encode . APIResponse Nothing <$> runReaderT (execChatCommand $ B.pack s) cc
+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 :: ByteString -> JSONByteString
-chatParseMarkdown = LB.unpack . J.encode . ParsedMarkdown . parseMaybeMarkdownList . safeDecodeUtf8 . B.pack
+chatParseMarkdown = J.encode . ParsedMarkdown . parseMaybeMarkdownList . safeDecodeUtf8
 
-chatParseServer :: String -> JSONString
+chatParseServer :: ByteString -> JSONByteString
-chatParseServer = LB.unpack . J.encode . toServerAddress . strDecode . B.pack
+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
+    salt' = U.decode salt
-    passwordHash = B.unpack . U.encode . C.sha512Hash . (encodeUtf8 (T.pack pwd) <>)
+    passwordHash = U.encode . C.sha512Hash . (pwd <>)
 
 data APIResponse = APIResponse {corr :: Maybe CorrId, resp :: ChatResponse}
   deriving (Generic)

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
+      let len = fromIntegral $ LB.length s
-          len = B.length s'
       ptr <- mallocBytes $ len + 5
-      poke ptr 0
+      poke ptr (0 :: Word8)
-      poke (ptr `plusPtr` 1) (fromIntegral len :: Word32)
+      pokeByteOff ptr 1 (fromIntegral len :: Word32)
-      putByteString (ptr `plusPtr` 5) s'
+      putLazyByteString (ptr `plusPtr` 5) s
       pure ptr
 
 chatReadFile :: FilePath -> ByteString -> ByteString -> IO (Either String LB.ByteString)

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
-import Foreign.ForeignPtr.Unsafe
 
 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
+putByteString ptr (BS fp len) =
-  let p = unsafeForeignPtrToPtr fp `plusPtr` offset
+  withForeignPtr fp $ \p -> memcpy ptr p len
-  memcpy ptr p $ B.length bs
+{-# 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

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
 

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