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
This commit is contained in:
Evgeny Poberezkin
GitHub
parent
08ea5dc2e7
commit
b3e880ee54
@ -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)
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user