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

module Simplex.FileTransfer.Server.StoreLog
  ( StoreLog,
    FileStoreLogRecord (..),
    closeStoreLog,
    readWriteFileStore,
    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.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 -> FileStore -> IO (StoreLog 'WriteMode)
readWriteFileStore :: String -> FileStore -> IO (StoreLog 'WriteMode)
readWriteFileStore = (String -> FileStore -> IO ())
-> (StoreLog 'WriteMode -> FileStore -> IO ())
-> String
-> FileStore
-> IO (StoreLog 'WriteMode)
forall s.
(String -> s -> IO ())
-> (StoreLog 'WriteMode -> s -> IO ())
-> String
-> s
-> IO (StoreLog 'WriteMode)
readWriteStoreLog String -> FileStore -> IO ()
readFileStore StoreLog 'WriteMode -> FileStore -> IO ()
writeFileStore

readFileStore :: FilePath -> FileStore -> IO ()
readFileStore :: String -> FileStore -> IO ()
readFileStore String
f FileStore
st = (LazyByteString -> IO ()) -> [LazyByteString] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ByteString -> IO ()
addFileLogRecord (ByteString -> IO ())
-> (LazyByteString -> ByteString) -> LazyByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LazyByteString -> ByteString
LB.toStrict) ([LazyByteString] -> IO ())
-> (LazyByteString -> [LazyByteString]) -> LazyByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LazyByteString -> [LazyByteString]
LB.lines (LazyByteString -> IO ()) -> IO LazyByteString -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO LazyByteString
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 ->
        STM (Either XFTPErrorType ()) -> IO (Either XFTPErrorType ())
forall a. STM a -> IO a
atomically (FileStoreLogRecord -> STM (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 -> STM (Either XFTPErrorType ())
addToStore = \case
      AddFile RecipientId
sId FileInfo
file RoundedFileTime
createdAt ServerEntityStatus
status -> FileStore
-> RecipientId
-> FileInfo
-> RoundedFileTime
-> ServerEntityStatus
-> STM (Either XFTPErrorType ())
addFile FileStore
st RecipientId
sId FileInfo
file RoundedFileTime
createdAt ServerEntityStatus
status
      PutFile RecipientId
qId String
path -> FileStore -> RecipientId -> String -> STM (Either XFTPErrorType ())
setFilePath FileStore
st RecipientId
qId String
path
      AddRecipients RecipientId
sId NonEmpty FileRecipient
rcps -> ExceptT XFTPErrorType STM () -> STM (Either XFTPErrorType ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT XFTPErrorType STM () -> STM (Either XFTPErrorType ()))
-> ExceptT XFTPErrorType STM () -> STM (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ RecipientId
-> NonEmpty FileRecipient -> ExceptT XFTPErrorType STM ()
addRecipients RecipientId
sId NonEmpty FileRecipient
rcps
      DeleteFile RecipientId
sId -> FileStore -> RecipientId -> STM (Either XFTPErrorType ())
deleteFile FileStore
st RecipientId
sId
      BlockFile RecipientId
sId BlockingInfo
info -> FileStore
-> RecipientId
-> BlockingInfo
-> Bool
-> STM (Either XFTPErrorType ())
blockFile FileStore
st RecipientId
sId BlockingInfo
info Bool
True
      AckFile RecipientId
rId -> FileStore -> RecipientId -> STM (Either XFTPErrorType ())
ackFile FileStore
st RecipientId
rId
    addRecipients :: RecipientId
-> NonEmpty FileRecipient -> ExceptT XFTPErrorType STM ()
addRecipients RecipientId
sId NonEmpty FileRecipient
rcps = (FileRecipient -> ExceptT XFTPErrorType STM ())
-> NonEmpty FileRecipient -> ExceptT XFTPErrorType STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (STM (Either XFTPErrorType ()) -> ExceptT XFTPErrorType STM ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (STM (Either XFTPErrorType ()) -> ExceptT XFTPErrorType STM ())
-> (FileRecipient -> STM (Either XFTPErrorType ()))
-> FileRecipient
-> ExceptT XFTPErrorType STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileStore
-> RecipientId -> FileRecipient -> STM (Either XFTPErrorType ())
addRecipient FileStore
st RecipientId
sId) NonEmpty FileRecipient
rcps

writeFileStore :: StoreLog 'WriteMode -> FileStore -> IO ()
writeFileStore :: StoreLog 'WriteMode -> FileStore -> IO ()
writeFileStore StoreLog 'WriteMode
s FileStore {TMap RecipientId FileRec
files :: TMap RecipientId FileRec
files :: FileStore -> TMap RecipientId FileRec
files, TMap RecipientId (RecipientId, RcvPublicAuthKey)
recipients :: TMap RecipientId (RecipientId, RcvPublicAuthKey)
recipients :: FileStore -> 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"