{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}

module Simplex.FileTransfer.Server.StoreLog
  ( StoreLog,
    FileStoreLogRecord (..),
    closeStoreLog,
    readWriteFileStore,
    writeFileStore,
    logAddFile,
    logPutFile,
    logAddRecipients,
    logDeleteFile,
    logBlockFile,
    logAckFile,
  )
where

import Control.Applicative ((<|>))
import Control.Concurrent.STM
import Control.Monad.Except
import qualified Data.Attoparsec.ByteString.Char8 as A
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Composition ((.:), (.::))
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Simplex.FileTransfer.Protocol (FileInfo (..))
import Simplex.FileTransfer.Server.Store
import Simplex.FileTransfer.Transport (XFTPErrorType (..))
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (BlockingInfo, RcvPublicAuthKey, RecipientId, SenderId)
import Simplex.Messaging.Server.QueueStore (ServerEntityStatus (..))
import Simplex.Messaging.Server.StoreLog
import Simplex.Messaging.Util (bshow)
import System.IO

data FileStoreLogRecord
  = AddFile SenderId FileInfo RoundedFileTime ServerEntityStatus
  | PutFile SenderId FilePath
  | AddRecipients SenderId (NonEmpty FileRecipient)
  | DeleteFile SenderId
  | BlockFile SenderId BlockingInfo
  | AckFile RecipientId -- TODO add senderId as well?
  deriving (Int -> FileStoreLogRecord -> ShowS
[FileStoreLogRecord] -> ShowS
FileStoreLogRecord -> String
(Int -> FileStoreLogRecord -> ShowS)
-> (FileStoreLogRecord -> String)
-> ([FileStoreLogRecord] -> ShowS)
-> Show FileStoreLogRecord
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FileStoreLogRecord -> ShowS
showsPrec :: Int -> FileStoreLogRecord -> ShowS
$cshow :: FileStoreLogRecord -> String
show :: FileStoreLogRecord -> String
$cshowList :: [FileStoreLogRecord] -> ShowS
showList :: [FileStoreLogRecord] -> ShowS
Show)

instance StrEncoding FileStoreLogRecord where
  strEncode :: FileStoreLogRecord -> ByteString
strEncode = \case
    AddFile RecipientId
sId FileInfo
file RoundedFileTime
createdAt ServerEntityStatus
status -> (Str, RecipientId, FileInfo, RoundedFileTime, ServerEntityStatus)
-> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode (ByteString -> Str
Str ByteString
"FNEW", RecipientId
sId, FileInfo
file, RoundedFileTime
createdAt, ServerEntityStatus
status)
    PutFile RecipientId
sId String
path -> (Str, RecipientId, String) -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode (ByteString -> Str
Str ByteString
"FPUT", RecipientId
sId, String
path)
    AddRecipients RecipientId
sId NonEmpty FileRecipient
rcps -> (Str, RecipientId, NonEmpty FileRecipient) -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode (ByteString -> Str
Str ByteString
"FADD", RecipientId
sId, NonEmpty FileRecipient
rcps)
    DeleteFile RecipientId
sId -> (Str, RecipientId) -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode (ByteString -> Str
Str ByteString
"FDEL", RecipientId
sId)
    BlockFile RecipientId
sId BlockingInfo
info -> (Str, RecipientId, BlockingInfo) -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode (ByteString -> Str
Str ByteString
"FBLK", RecipientId
sId, BlockingInfo
info)
    AckFile RecipientId
rId -> (Str, RecipientId) -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode (ByteString -> Str
Str ByteString
"FACK", RecipientId
rId)
  strP :: Parser FileStoreLogRecord
strP =
    [Parser FileStoreLogRecord] -> Parser FileStoreLogRecord
forall (f :: * -> *) a. Alternative f => [f a] -> f a
A.choice
      [ Parser ByteString ByteString
"FNEW " Parser ByteString ByteString
-> Parser FileStoreLogRecord -> Parser FileStoreLogRecord
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (RecipientId
-> FileInfo
-> RoundedFileTime
-> ServerEntityStatus
-> FileStoreLogRecord
AddFile (RecipientId
 -> FileInfo
 -> RoundedFileTime
 -> ServerEntityStatus
 -> FileStoreLogRecord)
-> Parser ByteString RecipientId
-> Parser
     ByteString
     (FileInfo
      -> RoundedFileTime -> ServerEntityStatus -> FileStoreLogRecord)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString RecipientId
forall a. StrEncoding a => Parser a
strP_ Parser
  ByteString
  (FileInfo
   -> RoundedFileTime -> ServerEntityStatus -> FileStoreLogRecord)
-> Parser ByteString FileInfo
-> Parser
     ByteString
     (RoundedFileTime -> ServerEntityStatus -> FileStoreLogRecord)
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString FileInfo
forall a. StrEncoding a => Parser a
strP_ Parser
  ByteString
  (RoundedFileTime -> ServerEntityStatus -> FileStoreLogRecord)
-> Parser ByteString RoundedFileTime
-> Parser ByteString (ServerEntityStatus -> FileStoreLogRecord)
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString RoundedFileTime
forall a. StrEncoding a => Parser a
strP Parser ByteString (ServerEntityStatus -> FileStoreLogRecord)
-> Parser ByteString ServerEntityStatus
-> Parser FileStoreLogRecord
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser ByteString ServerEntityStatus
forall a. StrEncoding a => Parser a
_strP Parser ByteString ServerEntityStatus
-> Parser ByteString ServerEntityStatus
-> Parser ByteString ServerEntityStatus
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ServerEntityStatus -> Parser ByteString ServerEntityStatus
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ServerEntityStatus
EntityActive)),
        Parser ByteString ByteString
"FPUT " Parser ByteString ByteString
-> Parser FileStoreLogRecord -> Parser FileStoreLogRecord
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (RecipientId -> String -> FileStoreLogRecord
PutFile (RecipientId -> String -> FileStoreLogRecord)
-> Parser ByteString RecipientId
-> Parser ByteString (String -> FileStoreLogRecord)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString RecipientId
forall a. StrEncoding a => Parser a
strP_ Parser ByteString (String -> FileStoreLogRecord)
-> Parser ByteString String -> Parser FileStoreLogRecord
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString String
forall a. StrEncoding a => Parser a
strP),
        Parser ByteString ByteString
"FADD " Parser ByteString ByteString
-> Parser FileStoreLogRecord -> Parser FileStoreLogRecord
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (RecipientId -> NonEmpty FileRecipient -> FileStoreLogRecord
AddRecipients (RecipientId -> NonEmpty FileRecipient -> FileStoreLogRecord)
-> Parser ByteString RecipientId
-> Parser ByteString (NonEmpty FileRecipient -> FileStoreLogRecord)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString RecipientId
forall a. StrEncoding a => Parser a
strP_ Parser ByteString (NonEmpty FileRecipient -> FileStoreLogRecord)
-> Parser ByteString (NonEmpty FileRecipient)
-> Parser FileStoreLogRecord
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString (NonEmpty FileRecipient)
forall a. StrEncoding a => Parser a
strP),
        Parser ByteString ByteString
"FDEL " Parser ByteString ByteString
-> Parser FileStoreLogRecord -> Parser FileStoreLogRecord
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (RecipientId -> FileStoreLogRecord
DeleteFile (RecipientId -> FileStoreLogRecord)
-> Parser ByteString RecipientId -> Parser FileStoreLogRecord
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString RecipientId
forall a. StrEncoding a => Parser a
strP),
        Parser ByteString ByteString
"FBLK " Parser ByteString ByteString
-> Parser FileStoreLogRecord -> Parser FileStoreLogRecord
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (RecipientId -> BlockingInfo -> FileStoreLogRecord
BlockFile (RecipientId -> BlockingInfo -> FileStoreLogRecord)
-> Parser ByteString RecipientId
-> Parser ByteString (BlockingInfo -> FileStoreLogRecord)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString RecipientId
forall a. StrEncoding a => Parser a
strP_ Parser ByteString (BlockingInfo -> FileStoreLogRecord)
-> Parser ByteString BlockingInfo -> Parser FileStoreLogRecord
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString BlockingInfo
forall a. StrEncoding a => Parser a
strP),
        Parser ByteString ByteString
"FACK " Parser ByteString ByteString
-> Parser FileStoreLogRecord -> Parser FileStoreLogRecord
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (RecipientId -> FileStoreLogRecord
AckFile (RecipientId -> FileStoreLogRecord)
-> Parser ByteString RecipientId -> Parser FileStoreLogRecord
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString RecipientId
forall a. StrEncoding a => Parser a
strP)
      ]

logFileStoreRecord :: StoreLog 'WriteMode -> FileStoreLogRecord -> IO ()
logFileStoreRecord :: StoreLog 'WriteMode -> FileStoreLogRecord -> IO ()
logFileStoreRecord = StoreLog 'WriteMode -> FileStoreLogRecord -> IO ()
forall r. StrEncoding r => StoreLog 'WriteMode -> r -> IO ()
writeStoreLogRecord

logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> RoundedFileTime -> ServerEntityStatus -> IO ()
logAddFile :: StoreLog 'WriteMode
-> RecipientId
-> FileInfo
-> RoundedFileTime
-> ServerEntityStatus
-> IO ()
logAddFile StoreLog 'WriteMode
s = StoreLog 'WriteMode -> FileStoreLogRecord -> IO ()
logFileStoreRecord StoreLog 'WriteMode
s (FileStoreLogRecord -> IO ())
-> (RecipientId
    -> FileInfo
    -> RoundedFileTime
    -> ServerEntityStatus
    -> FileStoreLogRecord)
-> RecipientId
-> FileInfo
-> RoundedFileTime
-> ServerEntityStatus
-> IO ()
forall {d} {e} {a1} {a2} {b} {c}.
(d -> e) -> (a1 -> a2 -> b -> c -> d) -> a1 -> a2 -> b -> c -> e
.:: RecipientId
-> FileInfo
-> RoundedFileTime
-> ServerEntityStatus
-> FileStoreLogRecord
AddFile

logPutFile :: StoreLog 'WriteMode -> SenderId -> FilePath -> IO ()
logPutFile :: StoreLog 'WriteMode -> RecipientId -> String -> IO ()
logPutFile StoreLog 'WriteMode
s = StoreLog 'WriteMode -> FileStoreLogRecord -> IO ()
logFileStoreRecord StoreLog 'WriteMode
s (FileStoreLogRecord -> IO ())
-> (RecipientId -> String -> FileStoreLogRecord)
-> RecipientId
-> String
-> IO ()
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: RecipientId -> String -> FileStoreLogRecord
PutFile

logAddRecipients :: StoreLog 'WriteMode -> SenderId -> NonEmpty FileRecipient -> IO ()
logAddRecipients :: StoreLog 'WriteMode
-> RecipientId -> NonEmpty FileRecipient -> IO ()
logAddRecipients StoreLog 'WriteMode
s = StoreLog 'WriteMode -> FileStoreLogRecord -> IO ()
logFileStoreRecord StoreLog 'WriteMode
s (FileStoreLogRecord -> IO ())
-> (RecipientId -> NonEmpty FileRecipient -> FileStoreLogRecord)
-> RecipientId
-> NonEmpty FileRecipient
-> IO ()
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: RecipientId -> NonEmpty FileRecipient -> FileStoreLogRecord
AddRecipients

logDeleteFile :: StoreLog 'WriteMode -> SenderId -> IO ()
logDeleteFile :: StoreLog 'WriteMode -> RecipientId -> IO ()
logDeleteFile StoreLog 'WriteMode
s = StoreLog 'WriteMode -> FileStoreLogRecord -> IO ()
logFileStoreRecord StoreLog 'WriteMode
s (FileStoreLogRecord -> IO ())
-> (RecipientId -> FileStoreLogRecord) -> RecipientId -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecipientId -> FileStoreLogRecord
DeleteFile

logBlockFile :: StoreLog 'WriteMode -> SenderId -> BlockingInfo -> IO ()
logBlockFile :: StoreLog 'WriteMode -> RecipientId -> BlockingInfo -> IO ()
logBlockFile StoreLog 'WriteMode
s RecipientId
fId = StoreLog 'WriteMode -> FileStoreLogRecord -> IO ()
logFileStoreRecord StoreLog 'WriteMode
s (FileStoreLogRecord -> IO ())
-> (BlockingInfo -> FileStoreLogRecord) -> BlockingInfo -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecipientId -> BlockingInfo -> FileStoreLogRecord
BlockFile RecipientId
fId

logAckFile :: StoreLog 'WriteMode -> RecipientId -> IO ()
logAckFile :: StoreLog 'WriteMode -> RecipientId -> IO ()
logAckFile StoreLog 'WriteMode
s = StoreLog 'WriteMode -> FileStoreLogRecord -> IO ()
logFileStoreRecord StoreLog 'WriteMode
s (FileStoreLogRecord -> IO ())
-> (RecipientId -> FileStoreLogRecord) -> RecipientId -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecipientId -> FileStoreLogRecord
AckFile

readWriteFileStore :: FilePath -> STMFileStore -> IO (StoreLog 'WriteMode)
readWriteFileStore :: String -> STMFileStore -> IO (StoreLog 'WriteMode)
readWriteFileStore = (String -> STMFileStore -> IO ())
-> (StoreLog 'WriteMode -> STMFileStore -> IO ())
-> String
-> STMFileStore
-> IO (StoreLog 'WriteMode)
forall s.
(String -> s -> IO ())
-> (StoreLog 'WriteMode -> s -> IO ())
-> String
-> s
-> IO (StoreLog 'WriteMode)
readWriteStoreLog String -> STMFileStore -> IO ()
readFileStore StoreLog 'WriteMode -> STMFileStore -> IO ()
writeFileStore

readFileStore :: FilePath -> STMFileStore -> IO ()
readFileStore :: String -> STMFileStore -> IO ()
readFileStore String
f STMFileStore
st = (ByteString -> IO ()) -> [ByteString] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ByteString -> IO ()
addFileLogRecord (ByteString -> IO ())
-> (ByteString -> ByteString) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LB.toStrict) ([ByteString] -> IO ())
-> (ByteString -> [ByteString]) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
LB.lines (ByteString -> IO ()) -> IO ByteString -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO ByteString
LB.readFile String
f
  where
    addFileLogRecord :: ByteString -> IO ()
addFileLogRecord ByteString
s = case ByteString -> Either String FileStoreLogRecord
forall a. StrEncoding a => ByteString -> Either String a
strDecode ByteString
s of
      Left String
e -> ByteString -> IO ()
B.putStrLn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
"Log parsing error (" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> String -> ByteString
B.pack String
e ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"): " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> ByteString -> ByteString
B.take Int
100 ByteString
s
      Right FileStoreLogRecord
lr ->
        FileStoreLogRecord -> IO (Either XFTPErrorType ())
addToStore FileStoreLogRecord
lr IO (Either XFTPErrorType ())
-> (Either XFTPErrorType () -> IO ()) -> IO ()
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 XFTPErrorType
e -> ByteString -> IO ()
B.putStrLn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
"Log processing error (" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> XFTPErrorType -> ByteString
forall a. Show a => a -> ByteString
bshow XFTPErrorType
e ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"): " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> ByteString -> ByteString
B.take Int
100 ByteString
s
          Either XFTPErrorType ()
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    addToStore :: FileStoreLogRecord -> IO (Either XFTPErrorType ())
addToStore = \case
      AddFile RecipientId
sId FileInfo
file RoundedFileTime
createdAt ServerEntityStatus
status
        | FileInfo -> Word32
size FileInfo
file Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
0 -> STMFileStore
-> RecipientId
-> FileInfo
-> RoundedFileTime
-> ServerEntityStatus
-> IO (Either XFTPErrorType ())
forall s.
FileStoreClass s =>
s
-> RecipientId
-> FileInfo
-> RoundedFileTime
-> ServerEntityStatus
-> IO (Either XFTPErrorType ())
addFile STMFileStore
st RecipientId
sId FileInfo
file RoundedFileTime
createdAt ServerEntityStatus
status
        | Bool
otherwise -> Either XFTPErrorType () -> IO (Either XFTPErrorType ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either XFTPErrorType () -> IO (Either XFTPErrorType ()))
-> Either XFTPErrorType () -> IO (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ XFTPErrorType -> Either XFTPErrorType ()
forall a b. a -> Either a b
Left XFTPErrorType
SIZE
      PutFile RecipientId
qId String
path -> STMFileStore
-> RecipientId -> String -> IO (Either XFTPErrorType ())
forall s.
FileStoreClass s =>
s -> RecipientId -> String -> IO (Either XFTPErrorType ())
setFilePath STMFileStore
st RecipientId
qId String
path
      AddRecipients RecipientId
sId NonEmpty FileRecipient
rcps -> ExceptT XFTPErrorType IO () -> IO (Either XFTPErrorType ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XFTPErrorType IO () -> IO (Either XFTPErrorType ()))
-> ExceptT XFTPErrorType IO () -> IO (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ RecipientId
-> NonEmpty FileRecipient -> ExceptT XFTPErrorType IO ()
addRecipients RecipientId
sId NonEmpty FileRecipient
rcps
      DeleteFile RecipientId
sId -> STMFileStore -> RecipientId -> IO (Either XFTPErrorType ())
forall s.
FileStoreClass s =>
s -> RecipientId -> IO (Either XFTPErrorType ())
deleteFile STMFileStore
st RecipientId
sId
      BlockFile RecipientId
sId BlockingInfo
info -> STMFileStore
-> RecipientId
-> BlockingInfo
-> Bool
-> IO (Either XFTPErrorType ())
forall s.
FileStoreClass s =>
s
-> RecipientId
-> BlockingInfo
-> Bool
-> IO (Either XFTPErrorType ())
blockFile STMFileStore
st RecipientId
sId BlockingInfo
info Bool
True
      AckFile RecipientId
rId -> STMFileStore -> RecipientId -> IO (Either XFTPErrorType ())
forall s.
FileStoreClass s =>
s -> RecipientId -> IO (Either XFTPErrorType ())
ackFile STMFileStore
st RecipientId
rId
    addRecipients :: RecipientId
-> NonEmpty FileRecipient -> ExceptT XFTPErrorType IO ()
addRecipients RecipientId
sId NonEmpty FileRecipient
rcps = (FileRecipient -> ExceptT XFTPErrorType IO ())
-> NonEmpty FileRecipient -> ExceptT XFTPErrorType IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IO (Either XFTPErrorType ()) -> ExceptT XFTPErrorType IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either XFTPErrorType ()) -> ExceptT XFTPErrorType IO ())
-> (FileRecipient -> IO (Either XFTPErrorType ()))
-> FileRecipient
-> ExceptT XFTPErrorType IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STMFileStore
-> RecipientId -> FileRecipient -> IO (Either XFTPErrorType ())
forall s.
FileStoreClass s =>
s -> RecipientId -> FileRecipient -> IO (Either XFTPErrorType ())
addRecipient STMFileStore
st RecipientId
sId) NonEmpty FileRecipient
rcps

writeFileStore :: StoreLog 'WriteMode -> STMFileStore -> IO ()
writeFileStore :: StoreLog 'WriteMode -> STMFileStore -> IO ()
writeFileStore StoreLog 'WriteMode
s STMFileStore {TMap RecipientId FileRec
files :: TMap RecipientId FileRec
files :: STMFileStore -> TMap RecipientId FileRec
files, TMap RecipientId (RecipientId, RcvPublicAuthKey)
recipients :: TMap RecipientId (RecipientId, RcvPublicAuthKey)
recipients :: STMFileStore -> TMap RecipientId (RecipientId, RcvPublicAuthKey)
recipients} = do
  Map RecipientId (RecipientId, RcvPublicAuthKey)
allRcps <- TMap RecipientId (RecipientId, RcvPublicAuthKey)
-> IO (Map RecipientId (RecipientId, RcvPublicAuthKey))
forall a. TVar a -> IO a
readTVarIO TMap RecipientId (RecipientId, RcvPublicAuthKey)
recipients
  TMap RecipientId FileRec -> IO (Map RecipientId FileRec)
forall a. TVar a -> IO a
readTVarIO TMap RecipientId FileRec
files IO (Map RecipientId FileRec)
-> (Map RecipientId FileRec -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (FileRec -> IO ()) -> Map RecipientId FileRec -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Map RecipientId (RecipientId, RcvPublicAuthKey) -> FileRec -> IO ()
logFile Map RecipientId (RecipientId, RcvPublicAuthKey)
allRcps)
  where
    logFile :: Map RecipientId (SenderId, RcvPublicAuthKey) -> FileRec -> IO ()
    logFile :: Map RecipientId (RecipientId, RcvPublicAuthKey) -> FileRec -> IO ()
logFile Map RecipientId (RecipientId, RcvPublicAuthKey)
allRcps FileRec {RecipientId
senderId :: RecipientId
senderId :: FileRec -> RecipientId
senderId, FileInfo
fileInfo :: FileInfo
fileInfo :: FileRec -> FileInfo
fileInfo, TVar (Maybe String)
filePath :: TVar (Maybe String)
filePath :: FileRec -> TVar (Maybe String)
filePath, TVar (Set RecipientId)
recipientIds :: TVar (Set RecipientId)
recipientIds :: FileRec -> TVar (Set RecipientId)
recipientIds, RoundedFileTime
createdAt :: RoundedFileTime
createdAt :: FileRec -> RoundedFileTime
createdAt, TVar ServerEntityStatus
fileStatus :: TVar ServerEntityStatus
fileStatus :: FileRec -> TVar ServerEntityStatus
fileStatus} = do
      ServerEntityStatus
status <- TVar ServerEntityStatus -> IO ServerEntityStatus
forall a. TVar a -> IO a
readTVarIO TVar ServerEntityStatus
fileStatus
      StoreLog 'WriteMode
-> RecipientId
-> FileInfo
-> RoundedFileTime
-> ServerEntityStatus
-> IO ()
logAddFile StoreLog 'WriteMode
s RecipientId
senderId FileInfo
fileInfo RoundedFileTime
createdAt ServerEntityStatus
status
      (Map RecipientId ByteString
rcpErrs, Map RecipientId FileRecipient
rcps) <- (RecipientId -> Either ByteString FileRecipient)
-> Map RecipientId RecipientId
-> (Map RecipientId ByteString, Map RecipientId FileRecipient)
forall a b c k. (a -> Either b c) -> Map k a -> (Map k b, Map k c)
M.mapEither RecipientId -> Either ByteString FileRecipient
getRcp (Map RecipientId RecipientId
 -> (Map RecipientId ByteString, Map RecipientId FileRecipient))
-> (Set RecipientId -> Map RecipientId RecipientId)
-> Set RecipientId
-> (Map RecipientId ByteString, Map RecipientId FileRecipient)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RecipientId -> RecipientId)
-> Set RecipientId -> Map RecipientId RecipientId
forall k a. (k -> a) -> Set k -> Map k a
M.fromSet RecipientId -> RecipientId
forall a. a -> a
id (Set RecipientId
 -> (Map RecipientId ByteString, Map RecipientId FileRecipient))
-> IO (Set RecipientId)
-> IO (Map RecipientId ByteString, Map RecipientId FileRecipient)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Set RecipientId) -> IO (Set RecipientId)
forall a. TVar a -> IO a
readTVarIO TVar (Set RecipientId)
recipientIds
      (NonEmpty FileRecipient -> IO ())
-> Maybe (NonEmpty FileRecipient) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (StoreLog 'WriteMode
-> RecipientId -> NonEmpty FileRecipient -> IO ()
logAddRecipients StoreLog 'WriteMode
s RecipientId
senderId) (Maybe (NonEmpty FileRecipient) -> IO ())
-> Maybe (NonEmpty FileRecipient) -> IO ()
forall a b. (a -> b) -> a -> b
$ [FileRecipient] -> Maybe (NonEmpty FileRecipient)
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty ([FileRecipient] -> Maybe (NonEmpty FileRecipient))
-> [FileRecipient] -> Maybe (NonEmpty FileRecipient)
forall a b. (a -> b) -> a -> b
$ Map RecipientId FileRecipient -> [FileRecipient]
forall k a. Map k a -> [a]
M.elems Map RecipientId FileRecipient
rcps
      (ByteString -> IO ()) -> Map RecipientId ByteString -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ByteString -> IO ()
B.putStrLn (ByteString -> IO ())
-> (ByteString -> ByteString) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
"Error storing log: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>)) Map RecipientId ByteString
rcpErrs
      TVar (Maybe String) -> IO (Maybe String)
forall a. TVar a -> IO a
readTVarIO TVar (Maybe String)
filePath IO (Maybe String) -> (Maybe String -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> IO ()) -> Maybe String -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (StoreLog 'WriteMode -> RecipientId -> String -> IO ()
logPutFile StoreLog 'WriteMode
s RecipientId
senderId)
      where
        getRcp :: RecipientId -> Either ByteString FileRecipient
getRcp RecipientId
rId = case RecipientId
-> Map RecipientId (RecipientId, RcvPublicAuthKey)
-> Maybe (RecipientId, RcvPublicAuthKey)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup RecipientId
rId Map RecipientId (RecipientId, RcvPublicAuthKey)
allRcps of
          Just (RecipientId
sndId, RcvPublicAuthKey
rKey)
            | RecipientId
sndId RecipientId -> RecipientId -> Bool
forall a. Eq a => a -> a -> Bool
== RecipientId
senderId -> FileRecipient -> Either ByteString FileRecipient
forall a b. b -> Either a b
Right (FileRecipient -> Either ByteString FileRecipient)
-> FileRecipient -> Either ByteString FileRecipient
forall a b. (a -> b) -> a -> b
$ RecipientId -> RcvPublicAuthKey -> FileRecipient
FileRecipient RecipientId
rId RcvPublicAuthKey
rKey
            | Bool
otherwise -> ByteString -> Either ByteString FileRecipient
forall a b. a -> Either a b
Left (ByteString -> Either ByteString FileRecipient)
-> ByteString -> Either ByteString FileRecipient
forall a b. (a -> b) -> a -> b
$ ByteString
"sender ID for recipient ID " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> RecipientId -> ByteString
forall a. Show a => a -> ByteString
bshow RecipientId
rId ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" does not match FileRec"
          Maybe (RecipientId, RcvPublicAuthKey)
Nothing -> ByteString -> Either ByteString FileRecipient
forall a b. a -> Either a b
Left (ByteString -> Either ByteString FileRecipient)
-> ByteString -> Either ByteString FileRecipient
forall a b. (a -> b) -> a -> b
$ ByteString
"recipient ID " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> RecipientId -> ByteString
forall a. Show a => a -> ByteString
bshow RecipientId
rId ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" not found"