{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} module Simplex.Chat.Mobile.File ( cChatWriteFile, cChatReadFile, cChatEncryptFile, cChatDecryptFile, WriteFileResult (..), ReadFileResult (..), chatWriteFile, chatReadFile, ) where import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class import qualified Data.Aeson as J import qualified Data.Aeson.TH as JQ import Data.ByteString (ByteString) import qualified Data.ByteString as B 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 (Word32, Word8) import Foreign.C import Foreign.Marshal.Alloc (mallocBytes) import Foreign.Ptr import Foreign.StablePtr import Foreign.Storable (poke, pokeByteOff) import Simplex.Chat.Controller (ChatController (..)) import Simplex.Chat.Mobile.Shared import Simplex.Chat.Util (chunkSize, encryptFile) import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..), CryptoFileHandle, FTCryptoError (..)) import qualified Simplex.Messaging.Crypto.File as CF import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON) import Simplex.Messaging.Util (catchAll) import UnliftIO (Handle, IOMode (..), atomically, withFile) data WriteFileResult = WFResult {WriteFileResult -> CryptoFileArgs cryptoArgs :: CryptoFileArgs} | WFError {WriteFileResult -> String writeError :: String} $(JQ.deriveToJSON (sumTypeJSON $ dropPrefix "WF") ''WriteFileResult) cChatWriteFile :: StablePtr ChatController -> CString -> Ptr Word8 -> CInt -> IO CJSONString cChatWriteFile :: StablePtr ChatController -> CString -> Ptr Word8 -> CInt -> IO CString cChatWriteFile StablePtr ChatController cc CString cPath Ptr Word8 ptr CInt len = do ChatController c <- StablePtr ChatController -> IO ChatController forall a. StablePtr a -> IO a deRefStablePtr StablePtr ChatController cc String path <- CString -> IO String peekCString CString cPath ByteString s <- Ptr Word8 -> CInt -> IO ByteString getByteString Ptr Word8 ptr CInt len WriteFileResult r <- ChatController -> String -> ByteString -> IO WriteFileResult chatWriteFile ChatController c String path ByteString s ByteString -> IO CString newCStringFromLazyBS (ByteString -> IO CString) -> ByteString -> IO CString forall a b. (a -> b) -> a -> b $ WriteFileResult -> ByteString forall a. ToJSON a => a -> ByteString J.encode WriteFileResult r chatWriteFile :: ChatController -> FilePath -> ByteString -> IO WriteFileResult chatWriteFile :: ChatController -> String -> ByteString -> IO WriteFileResult chatWriteFile ChatController {TVar ChaChaDRG random :: TVar ChaChaDRG random :: ChatController -> TVar ChaChaDRG random} String path ByteString s = do CryptoFileArgs cfArgs <- STM CryptoFileArgs -> IO CryptoFileArgs forall (m :: * -> *) a. MonadIO m => STM a -> m a atomically (STM CryptoFileArgs -> IO CryptoFileArgs) -> STM CryptoFileArgs -> IO CryptoFileArgs forall a b. (a -> b) -> a -> b $ TVar ChaChaDRG -> STM CryptoFileArgs CF.randomArgs TVar ChaChaDRG random let file :: CryptoFile file = String -> Maybe CryptoFileArgs -> CryptoFile CryptoFile String path (Maybe CryptoFileArgs -> CryptoFile) -> Maybe CryptoFileArgs -> CryptoFile forall a b. (a -> b) -> a -> b $ CryptoFileArgs -> Maybe CryptoFileArgs forall a. a -> Maybe a Just CryptoFileArgs cfArgs (String -> WriteFileResult) -> (() -> WriteFileResult) -> Either String () -> WriteFileResult forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either String -> WriteFileResult WFError (\() _ -> CryptoFileArgs -> WriteFileResult WFResult CryptoFileArgs cfArgs) (Either String () -> WriteFileResult) -> IO (Either String ()) -> IO WriteFileResult forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> ExceptT String IO () -> IO (Either String ()) forall a. ExceptT String IO a -> IO (Either String a) runCatchExceptT ((FTCryptoError -> String) -> ExceptT FTCryptoError IO () -> ExceptT String IO () forall (m :: * -> *) e e' a. Functor m => (e -> e') -> ExceptT e m a -> ExceptT e' m a withExceptT FTCryptoError -> String forall a. Show a => a -> String show (ExceptT FTCryptoError IO () -> ExceptT String IO ()) -> ExceptT FTCryptoError IO () -> ExceptT String IO () forall a b. (a -> b) -> a -> b $ CryptoFile -> ByteString -> ExceptT FTCryptoError IO () CF.writeFile CryptoFile file (ByteString -> ExceptT FTCryptoError IO ()) -> ByteString -> ExceptT FTCryptoError IO () forall a b. (a -> b) -> a -> b $ ByteString -> ByteString LB.fromStrict ByteString s) data ReadFileResult = RFResult {ReadFileResult -> Int fileSize :: Int} | RFError {ReadFileResult -> String readError :: String} cChatReadFile :: CString -> CString -> CString -> IO (Ptr Word8) cChatReadFile :: CString -> CString -> CString -> IO (Ptr Word8) cChatReadFile CString cPath CString cKey CString cNonce = do String path <- CString -> IO String peekCString CString cPath ByteString key <- CString -> IO ByteString B.packCString CString cKey ByteString nonce <- CString -> IO ByteString B.packCString CString cNonce String -> ByteString -> ByteString -> IO (Either String ByteString) chatReadFile String path ByteString key ByteString nonce IO (Either String ByteString) -> (Either String ByteString -> IO (Ptr Word8)) -> IO (Ptr Word8) forall a b. IO a -> (a -> IO b) -> IO b forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case Left String e -> CString -> Ptr Word8 forall a b. Ptr a -> Ptr b castPtr (CString -> Ptr Word8) -> IO CString -> IO (Ptr Word8) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> String -> IO CString newCString (Int -> Char chr Int 1 Char -> String -> String forall a. a -> [a] -> [a] : String e) Right ByteString s -> do let len :: Int len = Int64 -> Int forall a b. (Integral a, Num b) => a -> b fromIntegral (Int64 -> Int) -> Int64 -> Int forall a b. (a -> b) -> a -> b $ ByteString -> Int64 LB.length ByteString s Ptr Word8 ptr <- Int -> IO (Ptr Word8) forall a. Int -> IO (Ptr a) mallocBytes (Int -> IO (Ptr Word8)) -> Int -> IO (Ptr Word8) forall a b. (a -> b) -> a -> b $ Int len Int -> Int -> Int forall a. Num a => a -> a -> a + Int 5 Ptr Word8 -> Word8 -> IO () forall a. Storable a => Ptr a -> a -> IO () poke Ptr Word8 ptr (Word8 0 :: Word8) Ptr Word8 -> Int -> Word32 -> IO () forall b. Ptr b -> Int -> Word32 -> IO () forall a b. Storable a => Ptr b -> Int -> a -> IO () pokeByteOff Ptr Word8 ptr Int 1 (Int -> Word32 forall a b. (Integral a, Num b) => a -> b fromIntegral Int len :: Word32) Ptr Word8 -> ByteString -> IO () putLazyByteString (Ptr Word8 ptr Ptr Word8 -> Int -> Ptr Word8 forall a b. Ptr a -> Int -> Ptr b `plusPtr` Int 5) ByteString s Ptr Word8 -> IO (Ptr Word8) forall a. a -> IO a forall (f :: * -> *) a. Applicative f => a -> f a pure Ptr Word8 ptr chatReadFile :: FilePath -> ByteString -> ByteString -> IO (Either String LB.ByteString) chatReadFile :: String -> ByteString -> ByteString -> IO (Either String ByteString) chatReadFile String path ByteString keyStr ByteString nonceStr = ExceptT String IO ByteString -> IO (Either String ByteString) forall a. ExceptT String IO a -> IO (Either String a) runCatchExceptT (ExceptT String IO ByteString -> IO (Either String ByteString)) -> ExceptT String IO ByteString -> IO (Either String ByteString) forall a b. (a -> b) -> a -> b $ do SbKey key <- Either String SbKey -> ExceptT String IO SbKey forall e (m :: * -> *) a. MonadError e m => Either e a -> m a liftEither (Either String SbKey -> ExceptT String IO SbKey) -> Either String SbKey -> ExceptT String IO SbKey forall a b. (a -> b) -> a -> b $ ByteString -> Either String SbKey forall a. StrEncoding a => ByteString -> Either String a strDecode ByteString keyStr CbNonce nonce <- Either String CbNonce -> ExceptT String IO CbNonce forall e (m :: * -> *) a. MonadError e m => Either e a -> m a liftEither (Either String CbNonce -> ExceptT String IO CbNonce) -> Either String CbNonce -> ExceptT String IO CbNonce forall a b. (a -> b) -> a -> b $ ByteString -> Either String CbNonce forall a. StrEncoding a => ByteString -> Either String a strDecode ByteString nonceStr let file :: CryptoFile file = String -> Maybe CryptoFileArgs -> CryptoFile CryptoFile String path (Maybe CryptoFileArgs -> CryptoFile) -> Maybe CryptoFileArgs -> CryptoFile forall a b. (a -> b) -> a -> b $ CryptoFileArgs -> Maybe CryptoFileArgs forall a. a -> Maybe a Just (CryptoFileArgs -> Maybe CryptoFileArgs) -> CryptoFileArgs -> Maybe CryptoFileArgs forall a b. (a -> b) -> a -> b $ SbKey -> CbNonce -> CryptoFileArgs CFArgs SbKey key CbNonce nonce (FTCryptoError -> String) -> ExceptT FTCryptoError IO ByteString -> ExceptT String IO ByteString forall (m :: * -> *) e e' a. Functor m => (e -> e') -> ExceptT e m a -> ExceptT e' m a withExceptT FTCryptoError -> String forall a. Show a => a -> String show (ExceptT FTCryptoError IO ByteString -> ExceptT String IO ByteString) -> ExceptT FTCryptoError IO ByteString -> ExceptT String IO ByteString forall a b. (a -> b) -> a -> b $ CryptoFile -> ExceptT FTCryptoError IO ByteString CF.readFile CryptoFile file cChatEncryptFile :: StablePtr ChatController -> CString -> CString -> IO CJSONString cChatEncryptFile :: StablePtr ChatController -> CString -> CString -> IO CString cChatEncryptFile StablePtr ChatController cc CString cFromPath CString cToPath = do ChatController c <- StablePtr ChatController -> IO ChatController forall a. StablePtr a -> IO a deRefStablePtr StablePtr ChatController cc String fromPath <- CString -> IO String peekCString CString cFromPath String toPath <- CString -> IO String peekCString CString cToPath WriteFileResult r <- ChatController -> String -> String -> IO WriteFileResult chatEncryptFile ChatController c String fromPath String toPath String -> IO CString newCAString (String -> IO CString) -> (ByteString -> String) -> ByteString -> IO CString forall b c a. (b -> c) -> (a -> b) -> a -> c . ByteString -> String LB'.unpack (ByteString -> IO CString) -> ByteString -> IO CString forall a b. (a -> b) -> a -> b $ WriteFileResult -> ByteString forall a. ToJSON a => a -> ByteString J.encode WriteFileResult r chatEncryptFile :: ChatController -> FilePath -> FilePath -> IO WriteFileResult chatEncryptFile :: ChatController -> String -> String -> IO WriteFileResult chatEncryptFile ChatController {TVar ChaChaDRG random :: ChatController -> TVar ChaChaDRG random :: TVar ChaChaDRG random} String fromPath String toPath = (String -> WriteFileResult) -> (CryptoFileArgs -> WriteFileResult) -> Either String CryptoFileArgs -> WriteFileResult forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either String -> WriteFileResult WFError CryptoFileArgs -> WriteFileResult WFResult (Either String CryptoFileArgs -> WriteFileResult) -> IO (Either String CryptoFileArgs) -> IO WriteFileResult forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> ExceptT String IO CryptoFileArgs -> IO (Either String CryptoFileArgs) forall a. ExceptT String IO a -> IO (Either String a) runCatchExceptT ExceptT String IO CryptoFileArgs encrypt where encrypt :: ExceptT String IO CryptoFileArgs encrypt = do CryptoFileArgs cfArgs <- STM CryptoFileArgs -> ExceptT String IO CryptoFileArgs forall (m :: * -> *) a. MonadIO m => STM a -> m a atomically (STM CryptoFileArgs -> ExceptT String IO CryptoFileArgs) -> STM CryptoFileArgs -> ExceptT String IO CryptoFileArgs forall a b. (a -> b) -> a -> b $ TVar ChaChaDRG -> STM CryptoFileArgs CF.randomArgs TVar ChaChaDRG random String -> String -> CryptoFileArgs -> ExceptT String IO () encryptFile String fromPath String toPath CryptoFileArgs cfArgs CryptoFileArgs -> ExceptT String IO CryptoFileArgs forall a. a -> ExceptT String IO a forall (f :: * -> *) a. Applicative f => a -> f a pure CryptoFileArgs cfArgs cChatDecryptFile :: CString -> CString -> CString -> CString -> IO CString cChatDecryptFile :: CString -> CString -> CString -> CString -> IO CString cChatDecryptFile CString cFromPath CString cKey CString cNonce CString cToPath = do String fromPath <- CString -> IO String peekCString CString cFromPath ByteString key <- CString -> IO ByteString B.packCString CString cKey ByteString nonce <- CString -> IO ByteString B.packCString CString cNonce String toPath <- CString -> IO String peekCString CString cToPath String r <- String -> ByteString -> ByteString -> String -> IO String chatDecryptFile String fromPath ByteString key ByteString nonce String toPath String -> IO CString newCAString String r chatDecryptFile :: FilePath -> ByteString -> ByteString -> FilePath -> IO String chatDecryptFile :: String -> ByteString -> ByteString -> String -> IO String chatDecryptFile String fromPath ByteString keyStr ByteString nonceStr String toPath = String -> Either String () -> String forall a b. a -> Either a b -> a fromLeft String "" (Either String () -> String) -> IO (Either String ()) -> IO String forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> ExceptT String IO () -> IO (Either String ()) forall a. ExceptT String IO a -> IO (Either String a) runCatchExceptT ExceptT String IO () decrypt where decrypt :: ExceptT String IO () decrypt = do SbKey key <- Either String SbKey -> ExceptT String IO SbKey forall e (m :: * -> *) a. MonadError e m => Either e a -> m a liftEither (Either String SbKey -> ExceptT String IO SbKey) -> Either String SbKey -> ExceptT String IO SbKey forall a b. (a -> b) -> a -> b $ ByteString -> Either String SbKey forall a. StrEncoding a => ByteString -> Either String a strDecode ByteString keyStr CbNonce nonce <- Either String CbNonce -> ExceptT String IO CbNonce forall e (m :: * -> *) a. MonadError e m => Either e a -> m a liftEither (Either String CbNonce -> ExceptT String IO CbNonce) -> Either String CbNonce -> ExceptT String IO CbNonce forall a b. (a -> b) -> a -> b $ ByteString -> Either String CbNonce forall a. StrEncoding a => ByteString -> Either String a strDecode ByteString nonceStr let fromFile :: CryptoFile fromFile = String -> Maybe CryptoFileArgs -> CryptoFile CryptoFile String fromPath (Maybe CryptoFileArgs -> CryptoFile) -> Maybe CryptoFileArgs -> CryptoFile forall a b. (a -> b) -> a -> b $ CryptoFileArgs -> Maybe CryptoFileArgs forall a. a -> Maybe a Just (CryptoFileArgs -> Maybe CryptoFileArgs) -> CryptoFileArgs -> Maybe CryptoFileArgs forall a b. (a -> b) -> a -> b $ SbKey -> CbNonce -> CryptoFileArgs CFArgs SbKey key CbNonce nonce Integer size <- IO Integer -> ExceptT String IO Integer forall a. IO a -> ExceptT String IO a forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO Integer -> ExceptT String IO Integer) -> IO Integer -> ExceptT String IO Integer forall a b. (a -> b) -> a -> b $ CryptoFile -> IO Integer CF.getFileContentsSize CryptoFile fromFile (FTCryptoError -> String) -> ExceptT FTCryptoError IO () -> ExceptT String IO () forall (m :: * -> *) e e' a. Functor m => (e -> e') -> ExceptT e m a -> ExceptT e' m a withExceptT FTCryptoError -> String forall a. Show a => a -> String show (ExceptT FTCryptoError IO () -> ExceptT String IO ()) -> ExceptT FTCryptoError IO () -> ExceptT String IO () forall a b. (a -> b) -> a -> b $ CryptoFile -> IOMode -> (CryptoFileHandle -> ExceptT FTCryptoError IO ()) -> ExceptT FTCryptoError IO () forall a. CryptoFile -> IOMode -> (CryptoFileHandle -> ExceptT FTCryptoError IO a) -> ExceptT FTCryptoError IO a CF.withFile CryptoFile fromFile IOMode ReadMode ((CryptoFileHandle -> ExceptT FTCryptoError IO ()) -> ExceptT FTCryptoError IO ()) -> (CryptoFileHandle -> ExceptT FTCryptoError IO ()) -> ExceptT FTCryptoError IO () forall a b. (a -> b) -> a -> b $ \CryptoFileHandle r -> String -> IOMode -> (Handle -> ExceptT FTCryptoError IO ()) -> ExceptT FTCryptoError IO () forall (m :: * -> *) a. MonadUnliftIO m => String -> IOMode -> (Handle -> m a) -> m a withFile String toPath IOMode WriteMode ((Handle -> ExceptT FTCryptoError IO ()) -> ExceptT FTCryptoError IO ()) -> (Handle -> ExceptT FTCryptoError IO ()) -> ExceptT FTCryptoError IO () forall a b. (a -> b) -> a -> b $ \Handle w -> do CryptoFileHandle -> Handle -> Integer -> ExceptT FTCryptoError IO () decryptChunks CryptoFileHandle r Handle w Integer size CryptoFileHandle -> ExceptT FTCryptoError IO () CF.hGetTag CryptoFileHandle r decryptChunks :: CryptoFileHandle -> Handle -> Integer -> ExceptT FTCryptoError IO () decryptChunks :: CryptoFileHandle -> Handle -> Integer -> ExceptT FTCryptoError IO () decryptChunks CryptoFileHandle r Handle w !Integer size = do let chSize :: Integer chSize = Integer -> Integer -> Integer forall a. Ord a => a -> a -> a min Integer size Integer forall a. Num a => a chunkSize chSize' :: Int chSize' = Integer -> Int forall a b. (Integral a, Num b) => a -> b fromIntegral Integer chSize size' :: Integer size' = Integer size Integer -> Integer -> Integer forall a. Num a => a -> a -> a - Integer chSize ByteString ch <- IO ByteString -> ExceptT FTCryptoError IO ByteString forall a. IO a -> ExceptT FTCryptoError IO a forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO ByteString -> ExceptT FTCryptoError IO ByteString) -> IO ByteString -> ExceptT FTCryptoError IO ByteString forall a b. (a -> b) -> a -> b $ CryptoFileHandle -> Int -> IO ByteString CF.hGet CryptoFileHandle r Int chSize' Bool -> ExceptT FTCryptoError IO () -> ExceptT FTCryptoError IO () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (ByteString -> Int B.length ByteString ch Int -> Int -> Bool forall a. Eq a => a -> a -> Bool /= Int chSize') (ExceptT FTCryptoError IO () -> ExceptT FTCryptoError IO ()) -> ExceptT FTCryptoError IO () -> ExceptT FTCryptoError IO () forall a b. (a -> b) -> a -> b $ FTCryptoError -> ExceptT FTCryptoError IO () forall a. FTCryptoError -> ExceptT FTCryptoError IO a forall e (m :: * -> *) a. MonadError e m => e -> m a throwError (FTCryptoError -> ExceptT FTCryptoError IO ()) -> FTCryptoError -> ExceptT FTCryptoError IO () forall a b. (a -> b) -> a -> b $ String -> FTCryptoError FTCEFileIOError String "encrypting file: unexpected EOF" IO () -> ExceptT FTCryptoError IO () forall a. IO a -> ExceptT FTCryptoError IO a forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO () -> ExceptT FTCryptoError IO ()) -> IO () -> ExceptT FTCryptoError IO () forall a b. (a -> b) -> a -> b $ Handle -> ByteString -> IO () B.hPut Handle w ByteString ch Bool -> ExceptT FTCryptoError IO () -> ExceptT FTCryptoError IO () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (Integer size' Integer -> Integer -> Bool forall a. Ord a => a -> a -> Bool > Integer 0) (ExceptT FTCryptoError IO () -> ExceptT FTCryptoError IO ()) -> ExceptT FTCryptoError IO () -> ExceptT FTCryptoError IO () forall a b. (a -> b) -> a -> b $ CryptoFileHandle -> Handle -> Integer -> ExceptT FTCryptoError IO () decryptChunks CryptoFileHandle r Handle w Integer size' runCatchExceptT :: ExceptT String IO a -> IO (Either String a) runCatchExceptT :: forall a. ExceptT String IO a -> IO (Either String a) runCatchExceptT ExceptT String IO a action = ExceptT String IO a -> IO (Either String a) forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a) runExceptT ExceptT String IO a action IO (Either String a) -> (SomeException -> IO (Either String a)) -> IO (Either String a) forall a. IO a -> (SomeException -> IO a) -> IO a `catchAll` (Either String a -> IO (Either String a) forall a. a -> IO a forall (f :: * -> *) a. Applicative f => a -> f a pure (Either String a -> IO (Either String a)) -> (SomeException -> Either String a) -> SomeException -> IO (Either String a) forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> Either String a forall a b. a -> Either a b Left (String -> Either String a) -> (SomeException -> String) -> SomeException -> Either String a forall b c a. (b -> c) -> (a -> b) -> a -> c . SomeException -> String forall a. Show a => a -> String show) $(JQ.deriveToJSON (sumTypeJSON $ dropPrefix "RF") ''ReadFileResult)