Merge branch 'master' into master-ghc8107

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)

src/Simplex/Chat/Mobile/File.hs

@@ -25,11 +25,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)
@@ -52,7 +52,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
@@ -76,12 +76,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)

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

src/Simplex/Chat/Types.hs

@@ -1391,8 +1391,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