{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Simplex.Chat.Util (week, encryptFile, chunkSize, liftIOEither, shuffle, zipWith3') where

import Control.Exception (Exception)
import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Class
import Control.Monad.IO.Unlift (MonadUnliftIO (..))
import Control.Monad.Reader
import Data.Bifunctor (first)
import qualified Data.ByteString.Lazy as LB
import Data.List (sortBy)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Ord (comparing)
import Data.Time (NominalDiffTime)
import Data.Word (Word16)
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
import qualified Simplex.Messaging.Crypto.File as CF
import System.Random (randomRIO)
import qualified UnliftIO.Exception as E
import UnliftIO.IO (IOMode (..), withFile)

week :: NominalDiffTime
week :: NominalDiffTime
week = NominalDiffTime
7 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
86400

encryptFile :: FilePath -> FilePath -> CryptoFileArgs -> ExceptT String IO ()
encryptFile :: FilePath -> FilePath -> CryptoFileArgs -> ExceptT FilePath IO ()
encryptFile FilePath
fromPath FilePath
toPath CryptoFileArgs
cfArgs = do
  let toFile :: CryptoFile
toFile = FilePath -> Maybe CryptoFileArgs -> CryptoFile
CryptoFile FilePath
toPath (Maybe CryptoFileArgs -> CryptoFile)
-> Maybe CryptoFileArgs -> CryptoFile
forall a b. (a -> b) -> a -> b
$ CryptoFileArgs -> Maybe CryptoFileArgs
forall a. a -> Maybe a
Just CryptoFileArgs
cfArgs
  -- uncomment to test encryption error in runTestFileTransferEncrypted
  -- throwError "test error"
  (FTCryptoError -> FilePath)
-> ExceptT FTCryptoError IO () -> ExceptT FilePath IO ()
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT FTCryptoError -> FilePath
forall a. Show a => a -> FilePath
show (ExceptT FTCryptoError IO () -> ExceptT FilePath IO ())
-> ExceptT FTCryptoError IO () -> ExceptT FilePath IO ()
forall a b. (a -> b) -> a -> b
$
    FilePath
-> IOMode
-> (Handle -> ExceptT FTCryptoError IO ())
-> ExceptT FTCryptoError IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> IOMode -> (Handle -> m a) -> m a
withFile FilePath
fromPath IOMode
ReadMode ((Handle -> ExceptT FTCryptoError IO ())
 -> ExceptT FTCryptoError IO ())
-> (Handle -> ExceptT FTCryptoError IO ())
-> ExceptT FTCryptoError IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
r -> 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
toFile IOMode
WriteMode ((CryptoFileHandle -> ExceptT FTCryptoError IO ())
 -> ExceptT FTCryptoError IO ())
-> (CryptoFileHandle -> ExceptT FTCryptoError IO ())
-> ExceptT FTCryptoError IO ()
forall a b. (a -> b) -> a -> b
$ \CryptoFileHandle
w -> do
      Handle -> CryptoFileHandle -> ExceptT FTCryptoError IO ()
forall {m :: * -> *}.
MonadIO m =>
Handle -> CryptoFileHandle -> m ()
encryptChunks Handle
r CryptoFileHandle
w
      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
$ CryptoFileHandle -> IO ()
CF.hPutTag CryptoFileHandle
w
  where
    encryptChunks :: Handle -> CryptoFileHandle -> m ()
encryptChunks Handle
r CryptoFileHandle
w = do
      ByteString
ch <- IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ Handle -> Int -> IO ByteString
LB.hGet Handle
r Int
forall a. Num a => a
chunkSize
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
LB.null ByteString
ch) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ CryptoFileHandle -> ByteString -> IO ()
CF.hPut CryptoFileHandle
w ByteString
ch
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Int64
LB.length ByteString
ch Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
forall a. Num a => a
chunkSize) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> CryptoFileHandle -> m ()
encryptChunks Handle
r CryptoFileHandle
w

chunkSize :: Num a => a
chunkSize :: forall a. Num a => a
chunkSize = a
65536
{-# INLINE chunkSize #-}

shuffle :: [a] -> IO [a]
shuffle :: forall a. [a] -> IO [a]
shuffle [a]
xs = ((Word16, a) -> a) -> [(Word16, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Word16, a) -> a
forall a b. (a, b) -> b
snd ([(Word16, a)] -> [a])
-> ([(Word16, a)] -> [(Word16, a)]) -> [(Word16, a)] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Word16, a) -> (Word16, a) -> Ordering)
-> [(Word16, a)] -> [(Word16, a)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Word16, a) -> Word16) -> (Word16, a) -> (Word16, a) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Word16, a) -> Word16
forall a b. (a, b) -> a
fst) ([(Word16, a)] -> [a]) -> IO [(Word16, a)] -> IO [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> IO (Word16, a)) -> [a] -> IO [(Word16, a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\a
x -> (,a
x) (Word16 -> (Word16, a)) -> IO Word16 -> IO (Word16, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Word16
random) [a]
xs
  where
    random :: IO Word16
    random :: IO Word16
random = (Word16, Word16) -> IO Word16
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Word16
0, Word16
65535)

zipWith3' :: (a -> b -> c -> d) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d
zipWith3' :: forall a b c d.
(a -> b -> c -> d)
-> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d
zipWith3' a -> b -> c -> d
f ~(a
x :| [a]
xs) ~(b
y :| [b]
ys) ~(c
z :| [c]
zs) = a -> b -> c -> d
f a
x b
y c
z d -> [d] -> NonEmpty d
forall a. a -> [a] -> NonEmpty a
:| (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 a -> b -> c -> d
f [a]
xs [b]
ys [c]
zs

liftIOEither :: (MonadIO m, MonadError e m) => IO (Either e a) -> m a
liftIOEither :: forall (m :: * -> *) e a.
(MonadIO m, MonadError e m) =>
IO (Either e a) -> m a
liftIOEither IO (Either e a)
a = IO (Either e a) -> m (Either e a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Either e a)
a m (Either e a) -> (Either e a -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either e a -> m a
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
{-# INLINE liftIOEither #-}

newtype InternalException e = InternalException {forall e. InternalException e -> e
unInternalException :: e}
  deriving (InternalException e -> InternalException e -> Bool
(InternalException e -> InternalException e -> Bool)
-> (InternalException e -> InternalException e -> Bool)
-> Eq (InternalException e)
forall e.
Eq e =>
InternalException e -> InternalException e -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall e.
Eq e =>
InternalException e -> InternalException e -> Bool
== :: InternalException e -> InternalException e -> Bool
$c/= :: forall e.
Eq e =>
InternalException e -> InternalException e -> Bool
/= :: InternalException e -> InternalException e -> Bool
Eq, Int -> InternalException e -> ShowS
[InternalException e] -> ShowS
InternalException e -> FilePath
(Int -> InternalException e -> ShowS)
-> (InternalException e -> FilePath)
-> ([InternalException e] -> ShowS)
-> Show (InternalException e)
forall e. Show e => Int -> InternalException e -> ShowS
forall e. Show e => [InternalException e] -> ShowS
forall e. Show e => InternalException e -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall e. Show e => Int -> InternalException e -> ShowS
showsPrec :: Int -> InternalException e -> ShowS
$cshow :: forall e. Show e => InternalException e -> FilePath
show :: InternalException e -> FilePath
$cshowList :: forall e. Show e => [InternalException e] -> ShowS
showList :: [InternalException e] -> ShowS
Show)

instance Exception e => Exception (InternalException e)

instance Exception e => MonadUnliftIO (ExceptT e IO) where
  {-# INLINE withRunInIO #-}
  withRunInIO :: ((forall a. ExceptT e IO a -> IO a) -> IO b) -> ExceptT e IO b
  withRunInIO :: forall b.
((forall a. ExceptT e IO a -> IO a) -> IO b) -> ExceptT e IO b
withRunInIO (forall a. ExceptT e IO a -> IO a) -> IO b
inner =
    IO (Either e b) -> ExceptT e IO b
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either e b) -> ExceptT e IO b)
-> (IO b -> IO (Either e b)) -> IO b -> ExceptT e IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either (InternalException e) b -> Either e b)
-> IO (Either (InternalException e) b) -> IO (Either e b)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((InternalException e -> e)
-> Either (InternalException e) b -> Either e b
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first InternalException e -> e
forall e. InternalException e -> e
unInternalException) (IO (Either (InternalException e) b) -> IO (Either e b))
-> (IO b -> IO (Either (InternalException e) b))
-> IO b
-> IO (Either e b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO b -> IO (Either (InternalException e) b)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
E.try (IO b -> ExceptT e IO b) -> IO b -> ExceptT e IO b
forall a b. (a -> b) -> a -> b
$
      ((forall a. IO a -> IO a) -> IO b) -> IO b
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. IO a -> IO a) -> IO b) -> IO b)
-> ((forall a. IO a -> IO a) -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
run ->
        (forall a. ExceptT e IO a -> IO a) -> IO b
inner ((forall a. ExceptT e IO a -> IO a) -> IO b)
-> (forall a. ExceptT e IO a -> IO a) -> IO b
forall a b. (a -> b) -> a -> b
$ IO a -> IO a
forall a. IO a -> IO a
run (IO a -> IO a)
-> (ExceptT e IO a -> IO a) -> ExceptT e IO a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((e -> IO a) -> (a -> IO a) -> Either e a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (InternalException e -> IO a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO (InternalException e -> IO a)
-> (e -> InternalException e) -> e -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> InternalException e
forall e. e -> InternalException e
InternalException) a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either e a -> IO a)
-> (ExceptT e IO a -> IO (Either e a)) -> ExceptT e IO a -> IO a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ExceptT e IO a -> IO (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT)

instance Exception e => MonadUnliftIO (ExceptT e (ReaderT r IO)) where
  {-# INLINE withRunInIO #-}
  withRunInIO :: ((forall a. ExceptT e (ReaderT r IO) a -> IO a) -> IO b) -> ExceptT e (ReaderT r IO) b
  withRunInIO :: forall b.
((forall a. ExceptT e (ReaderT r IO) a -> IO a) -> IO b)
-> ExceptT e (ReaderT r IO) b
withRunInIO (forall a. ExceptT e (ReaderT r IO) a -> IO a) -> IO b
inner =
    (InternalException e -> e)
-> ExceptT (InternalException e) (ReaderT r IO) b
-> ExceptT e (ReaderT r IO) b
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT InternalException e -> e
forall e. InternalException e -> e
unInternalException (ExceptT (InternalException e) (ReaderT r IO) b
 -> ExceptT e (ReaderT r IO) b)
-> (ReaderT r IO b
    -> ExceptT (InternalException e) (ReaderT r IO) b)
-> ReaderT r IO b
-> ExceptT e (ReaderT r IO) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT r IO (Either (InternalException e) b)
-> ExceptT (InternalException e) (ReaderT r IO) b
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT r IO (Either (InternalException e) b)
 -> ExceptT (InternalException e) (ReaderT r IO) b)
-> (ReaderT r IO b
    -> ReaderT r IO (Either (InternalException e) b))
-> ReaderT r IO b
-> ExceptT (InternalException e) (ReaderT r IO) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT r IO b -> ReaderT r IO (Either (InternalException e) b)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
E.try (ReaderT r IO b -> ExceptT e (ReaderT r IO) b)
-> ReaderT r IO b -> ExceptT e (ReaderT r IO) b
forall a b. (a -> b) -> a -> b
$
      ((forall a. ReaderT r IO a -> IO a) -> IO b) -> ReaderT r IO b
forall b.
((forall a. ReaderT r IO a -> IO a) -> IO b) -> ReaderT r IO b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. ReaderT r IO a -> IO a) -> IO b) -> ReaderT r IO b)
-> ((forall a. ReaderT r IO a -> IO a) -> IO b) -> ReaderT r IO b
forall a b. (a -> b) -> a -> b
$ \forall a. ReaderT r IO a -> IO a
run ->
        (forall a. ExceptT e (ReaderT r IO) a -> IO a) -> IO b
inner ((forall a. ExceptT e (ReaderT r IO) a -> IO a) -> IO b)
-> (forall a. ExceptT e (ReaderT r IO) a -> IO a) -> IO b
forall a b. (a -> b) -> a -> b
$ ReaderT r IO a -> IO a
forall a. ReaderT r IO a -> IO a
run (ReaderT r IO a -> IO a)
-> (ExceptT e (ReaderT r IO) a -> ReaderT r IO a)
-> ExceptT e (ReaderT r IO) a
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((e -> ReaderT r IO a)
-> (a -> ReaderT r IO a) -> Either e a -> ReaderT r IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (InternalException e -> ReaderT r IO a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO (InternalException e -> ReaderT r IO a)
-> (e -> InternalException e) -> e -> ReaderT r IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> InternalException e
forall e. e -> InternalException e
InternalException) a -> ReaderT r IO a
forall a. a -> ReaderT r IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either e a -> ReaderT r IO a)
-> (ExceptT e (ReaderT r IO) a -> ReaderT r IO (Either e a))
-> ExceptT e (ReaderT r IO) a
-> ReaderT r IO a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ExceptT e (ReaderT r IO) a -> ReaderT r IO (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT)