{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}

module Simplex.FileTransfer.Server.Store
  ( FSType (..),
    SFSType (..),
    FileStoreClass (..),
    FileRec (..),
    FileRecipient (..),
    STMFileStore (..),
    RoundedFileTime,
    fileTimePrecision,
  )
where

import Data.Kind (Type)

import Control.Concurrent.STM
import Control.Monad (forM, void)
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Int (Int64)
import qualified Data.Map.Strict as M
import Data.Maybe (catMaybes)
import Data.Set (Set)
import qualified Data.Set as S
import Data.Word (Word32)
import Simplex.FileTransfer.Protocol (FileInfo (..), SFileParty (..), XFTPFileId)
import Simplex.FileTransfer.Transport (XFTPErrorType (..))
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (BlockingInfo, RcvPublicAuthKey, RecipientId, SenderId)
import Simplex.Messaging.Server.QueueStore (ServerEntityStatus (..))
import Simplex.Messaging.Server.StoreLog (StoreLog, closeStoreLog)
import System.IO (IOMode (..))
import Simplex.Messaging.SystemTime
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Util (ifM)

data FSType = FSMemory | FSPostgres

data SFSType :: FSType -> Type where
  SFSMemory :: SFSType 'FSMemory
  SFSPostgres :: SFSType 'FSPostgres

data FileRec = FileRec
  { FileRec -> SenderId
senderId :: SenderId,
    FileRec -> FileInfo
fileInfo :: FileInfo,
    FileRec -> TVar (Maybe FilePath)
filePath :: TVar (Maybe FilePath),
    FileRec -> TVar (Set SenderId)
recipientIds :: TVar (Set RecipientId),
    FileRec -> RoundedFileTime
createdAt :: RoundedFileTime,
    FileRec -> TVar ServerEntityStatus
fileStatus :: TVar ServerEntityStatus
  }

type RoundedFileTime = RoundedSystemTime 3600

fileTimePrecision :: Int64
fileTimePrecision :: Int64
fileTimePrecision = Int64
3600

data FileRecipient = FileRecipient RecipientId C.APublicAuthKey
  deriving (Int -> FileRecipient -> ShowS
[FileRecipient] -> ShowS
FileRecipient -> FilePath
(Int -> FileRecipient -> ShowS)
-> (FileRecipient -> FilePath)
-> ([FileRecipient] -> ShowS)
-> Show FileRecipient
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FileRecipient -> ShowS
showsPrec :: Int -> FileRecipient -> ShowS
$cshow :: FileRecipient -> FilePath
show :: FileRecipient -> FilePath
$cshowList :: [FileRecipient] -> ShowS
showList :: [FileRecipient] -> ShowS
Show)

instance StrEncoding FileRecipient where
  strEncode :: FileRecipient -> ByteString
strEncode (FileRecipient SenderId
rId APublicAuthKey
rKey) = SenderId -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode SenderId
rId ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
":" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> APublicAuthKey -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode APublicAuthKey
rKey
  strP :: Parser FileRecipient
strP = SenderId -> APublicAuthKey -> FileRecipient
FileRecipient (SenderId -> APublicAuthKey -> FileRecipient)
-> Parser ByteString SenderId
-> Parser ByteString (APublicAuthKey -> FileRecipient)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString SenderId
forall a. StrEncoding a => Parser a
strP Parser ByteString (APublicAuthKey -> FileRecipient)
-> Parser ByteString Char
-> Parser ByteString (APublicAuthKey -> FileRecipient)
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
A.char Char
':' Parser ByteString (APublicAuthKey -> FileRecipient)
-> Parser ByteString APublicAuthKey -> Parser FileRecipient
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 APublicAuthKey
forall a. StrEncoding a => Parser a
strP

class FileStoreClass s where
  type FileStoreConfig s
  newFileStore :: FileStoreConfig s -> IO s
  closeFileStore :: s -> IO ()
  addFile :: s -> SenderId -> FileInfo -> RoundedFileTime -> ServerEntityStatus -> IO (Either XFTPErrorType ())
  setFilePath :: s -> SenderId -> FilePath -> IO (Either XFTPErrorType ())
  addRecipient :: s -> SenderId -> FileRecipient -> IO (Either XFTPErrorType ())
  deleteFile :: s -> SenderId -> IO (Either XFTPErrorType ())
  deleteFiles :: s -> [SenderId] -> IO ()
  deleteFiles s
s = (SenderId -> IO ()) -> [SenderId] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IO (Either XFTPErrorType ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either XFTPErrorType ()) -> IO ())
-> (SenderId -> IO (Either XFTPErrorType ())) -> SenderId -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> SenderId -> IO (Either XFTPErrorType ())
forall s.
FileStoreClass s =>
s -> SenderId -> IO (Either XFTPErrorType ())
deleteFile s
s)
  blockFile :: s -> SenderId -> BlockingInfo -> Bool -> IO (Either XFTPErrorType ())
  deleteRecipient :: s -> RecipientId -> FileRec -> IO ()
  getFile :: s -> SFileParty p -> XFTPFileId -> IO (Either XFTPErrorType (FileRec, C.APublicAuthKey))
  ackFile :: s -> RecipientId -> IO (Either XFTPErrorType ())
  expiredFiles :: s -> Int64 -> Int -> IO [(SenderId, Maybe FilePath, Word32)]
  getUsedStorage :: s -> IO Int64
  getFileCount :: s -> IO Int

-- STM in-memory store

data STMFileStore = STMFileStore
  { STMFileStore -> TMap SenderId FileRec
files :: TMap SenderId FileRec,
    STMFileStore -> TMap SenderId (SenderId, APublicAuthKey)
recipients :: TMap RecipientId (SenderId, RcvPublicAuthKey),
    STMFileStore -> TVar (Maybe (StoreLog 'WriteMode))
stmStoreLog :: TVar (Maybe (StoreLog 'WriteMode))
  }

instance FileStoreClass STMFileStore where
  type FileStoreConfig STMFileStore = ()

  newFileStore :: FileStoreConfig STMFileStore -> IO STMFileStore
newFileStore () = do
    TMap SenderId FileRec
files <- IO (TMap SenderId FileRec)
forall k a. IO (TMap k a)
TM.emptyIO
    TMap SenderId (SenderId, APublicAuthKey)
recipients <- IO (TMap SenderId (SenderId, APublicAuthKey))
forall k a. IO (TMap k a)
TM.emptyIO
    TVar (Maybe (StoreLog 'WriteMode))
stmStoreLog <- Maybe (StoreLog 'WriteMode)
-> IO (TVar (Maybe (StoreLog 'WriteMode)))
forall a. a -> IO (TVar a)
newTVarIO Maybe (StoreLog 'WriteMode)
forall a. Maybe a
Nothing
    STMFileStore -> IO STMFileStore
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure STMFileStore {TMap SenderId FileRec
files :: TMap SenderId FileRec
files :: TMap SenderId FileRec
files, TMap SenderId (SenderId, APublicAuthKey)
recipients :: TMap SenderId (SenderId, APublicAuthKey)
recipients :: TMap SenderId (SenderId, APublicAuthKey)
recipients, TVar (Maybe (StoreLog 'WriteMode))
stmStoreLog :: TVar (Maybe (StoreLog 'WriteMode))
stmStoreLog :: TVar (Maybe (StoreLog 'WriteMode))
stmStoreLog}

  closeFileStore :: STMFileStore -> IO ()
closeFileStore STMFileStore {TVar (Maybe (StoreLog 'WriteMode))
stmStoreLog :: STMFileStore -> TVar (Maybe (StoreLog 'WriteMode))
stmStoreLog :: TVar (Maybe (StoreLog 'WriteMode))
stmStoreLog} = TVar (Maybe (StoreLog 'WriteMode))
-> IO (Maybe (StoreLog 'WriteMode))
forall a. TVar a -> IO a
readTVarIO TVar (Maybe (StoreLog 'WriteMode))
stmStoreLog IO (Maybe (StoreLog 'WriteMode))
-> (Maybe (StoreLog 'WriteMode) -> 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
>>= (StoreLog 'WriteMode -> IO ())
-> Maybe (StoreLog 'WriteMode) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ StoreLog 'WriteMode -> IO ()
forall (a :: IOMode). StoreLog a -> IO ()
closeStoreLog

  addFile :: STMFileStore
-> SenderId
-> FileInfo
-> RoundedFileTime
-> ServerEntityStatus
-> IO (Either XFTPErrorType ())
addFile STMFileStore {TMap SenderId FileRec
files :: STMFileStore -> TMap SenderId FileRec
files :: TMap SenderId FileRec
files} SenderId
sId FileInfo
fileInfo RoundedFileTime
createdAt ServerEntityStatus
status = STM (Either XFTPErrorType ()) -> IO (Either XFTPErrorType ())
forall a. STM a -> IO a
atomically (STM (Either XFTPErrorType ()) -> IO (Either XFTPErrorType ()))
-> STM (Either XFTPErrorType ()) -> IO (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$
    STM Bool
-> STM (Either XFTPErrorType ())
-> STM (Either XFTPErrorType ())
-> STM (Either XFTPErrorType ())
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (SenderId -> TMap SenderId FileRec -> STM Bool
forall k a. Ord k => k -> TMap k a -> STM Bool
TM.member SenderId
sId TMap SenderId FileRec
files) (Either XFTPErrorType () -> STM (Either XFTPErrorType ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either XFTPErrorType () -> STM (Either XFTPErrorType ()))
-> Either XFTPErrorType () -> STM (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ XFTPErrorType -> Either XFTPErrorType ()
forall a b. a -> Either a b
Left XFTPErrorType
DUPLICATE_) (STM (Either XFTPErrorType ()) -> STM (Either XFTPErrorType ()))
-> STM (Either XFTPErrorType ()) -> STM (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ do
      FileRec
f <- SenderId
-> FileInfo -> RoundedFileTime -> ServerEntityStatus -> STM FileRec
newFileRec SenderId
sId FileInfo
fileInfo RoundedFileTime
createdAt ServerEntityStatus
status
      SenderId -> FileRec -> TMap SenderId FileRec -> STM ()
forall k a. Ord k => k -> a -> TMap k a -> STM ()
TM.insert SenderId
sId FileRec
f TMap SenderId FileRec
files
      Either XFTPErrorType () -> STM (Either XFTPErrorType ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either XFTPErrorType () -> STM (Either XFTPErrorType ()))
-> Either XFTPErrorType () -> STM (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ () -> Either XFTPErrorType ()
forall a b. b -> Either a b
Right ()

  setFilePath :: STMFileStore
-> SenderId -> FilePath -> IO (Either XFTPErrorType ())
setFilePath STMFileStore
st SenderId
sId FilePath
fPath = STM (Either XFTPErrorType ()) -> IO (Either XFTPErrorType ())
forall a. STM a -> IO a
atomically (STM (Either XFTPErrorType ()) -> IO (Either XFTPErrorType ()))
-> STM (Either XFTPErrorType ()) -> IO (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$
    STMFileStore
-> SenderId
-> (FileRec -> STM (Either XFTPErrorType ()))
-> STM (Either XFTPErrorType ())
forall a.
STMFileStore
-> SenderId
-> (FileRec -> STM (Either XFTPErrorType a))
-> STM (Either XFTPErrorType a)
withFile STMFileStore
st SenderId
sId ((FileRec -> STM (Either XFTPErrorType ()))
 -> STM (Either XFTPErrorType ()))
-> (FileRec -> STM (Either XFTPErrorType ()))
-> STM (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ \FileRec {TVar (Maybe FilePath)
filePath :: FileRec -> TVar (Maybe FilePath)
filePath :: TVar (Maybe FilePath)
filePath, TVar ServerEntityStatus
fileStatus :: FileRec -> TVar ServerEntityStatus
fileStatus :: TVar ServerEntityStatus
fileStatus} -> do
      TVar (Maybe FilePath) -> STM (Maybe FilePath)
forall a. TVar a -> STM a
readTVar TVar (Maybe FilePath)
filePath STM (Maybe FilePath)
-> (Maybe FilePath -> STM (Either XFTPErrorType ()))
-> STM (Either XFTPErrorType ())
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just FilePath
_ -> Either XFTPErrorType () -> STM (Either XFTPErrorType ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either XFTPErrorType () -> STM (Either XFTPErrorType ()))
-> Either XFTPErrorType () -> STM (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ XFTPErrorType -> Either XFTPErrorType ()
forall a b. a -> Either a b
Left XFTPErrorType
AUTH
        Maybe FilePath
Nothing ->
          TVar ServerEntityStatus -> STM ServerEntityStatus
forall a. TVar a -> STM a
readTVar TVar ServerEntityStatus
fileStatus STM ServerEntityStatus
-> (ServerEntityStatus -> STM (Either XFTPErrorType ()))
-> STM (Either XFTPErrorType ())
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            ServerEntityStatus
EntityActive -> do
              TVar (Maybe FilePath) -> Maybe FilePath -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe FilePath)
filePath (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
fPath)
              Either XFTPErrorType () -> STM (Either XFTPErrorType ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either XFTPErrorType () -> STM (Either XFTPErrorType ()))
-> Either XFTPErrorType () -> STM (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ () -> Either XFTPErrorType ()
forall a b. b -> Either a b
Right ()
            ServerEntityStatus
_ -> Either XFTPErrorType () -> STM (Either XFTPErrorType ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either XFTPErrorType () -> STM (Either XFTPErrorType ()))
-> Either XFTPErrorType () -> STM (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ XFTPErrorType -> Either XFTPErrorType ()
forall a b. a -> Either a b
Left XFTPErrorType
AUTH

  addRecipient :: STMFileStore
-> SenderId -> FileRecipient -> IO (Either XFTPErrorType ())
addRecipient st :: STMFileStore
st@STMFileStore {TMap SenderId (SenderId, APublicAuthKey)
recipients :: STMFileStore -> TMap SenderId (SenderId, APublicAuthKey)
recipients :: TMap SenderId (SenderId, APublicAuthKey)
recipients} SenderId
senderId (FileRecipient SenderId
rId APublicAuthKey
rKey) = STM (Either XFTPErrorType ()) -> IO (Either XFTPErrorType ())
forall a. STM a -> IO a
atomically (STM (Either XFTPErrorType ()) -> IO (Either XFTPErrorType ()))
-> STM (Either XFTPErrorType ()) -> IO (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$
    STMFileStore
-> SenderId
-> (FileRec -> STM (Either XFTPErrorType ()))
-> STM (Either XFTPErrorType ())
forall a.
STMFileStore
-> SenderId
-> (FileRec -> STM (Either XFTPErrorType a))
-> STM (Either XFTPErrorType a)
withFile STMFileStore
st SenderId
senderId ((FileRec -> STM (Either XFTPErrorType ()))
 -> STM (Either XFTPErrorType ()))
-> (FileRec -> STM (Either XFTPErrorType ()))
-> STM (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ \FileRec {TVar (Set SenderId)
recipientIds :: FileRec -> TVar (Set SenderId)
recipientIds :: TVar (Set SenderId)
recipientIds} -> do
      Set SenderId
rIds <- TVar (Set SenderId) -> STM (Set SenderId)
forall a. TVar a -> STM a
readTVar TVar (Set SenderId)
recipientIds
      Bool
mem <- SenderId -> TMap SenderId (SenderId, APublicAuthKey) -> STM Bool
forall k a. Ord k => k -> TMap k a -> STM Bool
TM.member SenderId
rId TMap SenderId (SenderId, APublicAuthKey)
recipients
      if SenderId
rId SenderId -> Set SenderId -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set SenderId
rIds Bool -> Bool -> Bool
|| Bool
mem
        then Either XFTPErrorType () -> STM (Either XFTPErrorType ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either XFTPErrorType () -> STM (Either XFTPErrorType ()))
-> Either XFTPErrorType () -> STM (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ XFTPErrorType -> Either XFTPErrorType ()
forall a b. a -> Either a b
Left XFTPErrorType
DUPLICATE_
        else do
          TVar (Set SenderId) -> Set SenderId -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Set SenderId)
recipientIds (Set SenderId -> STM ()) -> Set SenderId -> STM ()
forall a b. (a -> b) -> a -> b
$! SenderId -> Set SenderId -> Set SenderId
forall a. Ord a => a -> Set a -> Set a
S.insert SenderId
rId Set SenderId
rIds
          SenderId
-> (SenderId, APublicAuthKey)
-> TMap SenderId (SenderId, APublicAuthKey)
-> STM ()
forall k a. Ord k => k -> a -> TMap k a -> STM ()
TM.insert SenderId
rId (SenderId
senderId, APublicAuthKey
rKey) TMap SenderId (SenderId, APublicAuthKey)
recipients
          Either XFTPErrorType () -> STM (Either XFTPErrorType ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either XFTPErrorType () -> STM (Either XFTPErrorType ()))
-> Either XFTPErrorType () -> STM (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ () -> Either XFTPErrorType ()
forall a b. b -> Either a b
Right ()

  deleteFile :: STMFileStore -> SenderId -> IO (Either XFTPErrorType ())
deleteFile STMFileStore {TMap SenderId FileRec
files :: STMFileStore -> TMap SenderId FileRec
files :: TMap SenderId FileRec
files, TMap SenderId (SenderId, APublicAuthKey)
recipients :: STMFileStore -> TMap SenderId (SenderId, APublicAuthKey)
recipients :: TMap SenderId (SenderId, APublicAuthKey)
recipients} SenderId
senderId = STM (Either XFTPErrorType ()) -> IO (Either XFTPErrorType ())
forall a. STM a -> IO a
atomically (STM (Either XFTPErrorType ()) -> IO (Either XFTPErrorType ()))
-> STM (Either XFTPErrorType ()) -> IO (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ do
    SenderId -> TMap SenderId FileRec -> STM (Maybe FileRec)
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookupDelete SenderId
senderId TMap SenderId FileRec
files STM (Maybe FileRec)
-> (Maybe FileRec -> STM (Either XFTPErrorType ()))
-> STM (Either XFTPErrorType ())
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just FileRec {TVar (Set SenderId)
recipientIds :: FileRec -> TVar (Set SenderId)
recipientIds :: TVar (Set SenderId)
recipientIds} -> do
        TVar (Set SenderId) -> STM (Set SenderId)
forall a. TVar a -> STM a
readTVar TVar (Set SenderId)
recipientIds STM (Set SenderId) -> (Set SenderId -> STM ()) -> STM ()
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SenderId -> STM ()) -> Set SenderId -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SenderId -> TMap SenderId (SenderId, APublicAuthKey) -> STM ()
forall k a. Ord k => k -> TMap k a -> STM ()
`TM.delete` TMap SenderId (SenderId, APublicAuthKey)
recipients)
        Either XFTPErrorType () -> STM (Either XFTPErrorType ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either XFTPErrorType () -> STM (Either XFTPErrorType ()))
-> Either XFTPErrorType () -> STM (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ () -> Either XFTPErrorType ()
forall a b. b -> Either a b
Right ()
      Maybe FileRec
_ -> Either XFTPErrorType () -> STM (Either XFTPErrorType ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either XFTPErrorType () -> STM (Either XFTPErrorType ()))
-> Either XFTPErrorType () -> STM (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ XFTPErrorType -> Either XFTPErrorType ()
forall a b. a -> Either a b
Left XFTPErrorType
AUTH

  blockFile :: STMFileStore
-> SenderId -> BlockingInfo -> Bool -> IO (Either XFTPErrorType ())
blockFile STMFileStore
st SenderId
senderId BlockingInfo
info Bool
_deleted = STM (Either XFTPErrorType ()) -> IO (Either XFTPErrorType ())
forall a. STM a -> IO a
atomically (STM (Either XFTPErrorType ()) -> IO (Either XFTPErrorType ()))
-> STM (Either XFTPErrorType ()) -> IO (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$
    STMFileStore
-> SenderId
-> (FileRec -> STM (Either XFTPErrorType ()))
-> STM (Either XFTPErrorType ())
forall a.
STMFileStore
-> SenderId
-> (FileRec -> STM (Either XFTPErrorType a))
-> STM (Either XFTPErrorType a)
withFile STMFileStore
st SenderId
senderId ((FileRec -> STM (Either XFTPErrorType ()))
 -> STM (Either XFTPErrorType ()))
-> (FileRec -> STM (Either XFTPErrorType ()))
-> STM (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ \FileRec {TVar ServerEntityStatus
fileStatus :: FileRec -> TVar ServerEntityStatus
fileStatus :: TVar ServerEntityStatus
fileStatus} -> do
      TVar ServerEntityStatus -> ServerEntityStatus -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar ServerEntityStatus
fileStatus (ServerEntityStatus -> STM ()) -> ServerEntityStatus -> STM ()
forall a b. (a -> b) -> a -> b
$! BlockingInfo -> ServerEntityStatus
EntityBlocked BlockingInfo
info
      Either XFTPErrorType () -> STM (Either XFTPErrorType ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either XFTPErrorType () -> STM (Either XFTPErrorType ()))
-> Either XFTPErrorType () -> STM (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ () -> Either XFTPErrorType ()
forall a b. b -> Either a b
Right ()

  deleteRecipient :: STMFileStore -> SenderId -> FileRec -> IO ()
deleteRecipient STMFileStore {TMap SenderId (SenderId, APublicAuthKey)
recipients :: STMFileStore -> TMap SenderId (SenderId, APublicAuthKey)
recipients :: TMap SenderId (SenderId, APublicAuthKey)
recipients} SenderId
rId FileRec {TVar (Set SenderId)
recipientIds :: FileRec -> TVar (Set SenderId)
recipientIds :: TVar (Set SenderId)
recipientIds} = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    SenderId -> TMap SenderId (SenderId, APublicAuthKey) -> STM ()
forall k a. Ord k => k -> TMap k a -> STM ()
TM.delete SenderId
rId TMap SenderId (SenderId, APublicAuthKey)
recipients
    TVar (Set SenderId) -> (Set SenderId -> Set SenderId) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (Set SenderId)
recipientIds ((Set SenderId -> Set SenderId) -> STM ())
-> (Set SenderId -> Set SenderId) -> STM ()
forall a b. (a -> b) -> a -> b
$ SenderId -> Set SenderId -> Set SenderId
forall a. Ord a => a -> Set a -> Set a
S.delete SenderId
rId

  getFile :: forall (p :: FileParty).
STMFileStore
-> SFileParty p
-> SenderId
-> IO (Either XFTPErrorType (FileRec, APublicAuthKey))
getFile STMFileStore
st SFileParty p
party SenderId
fId = STM (Either XFTPErrorType (FileRec, APublicAuthKey))
-> IO (Either XFTPErrorType (FileRec, APublicAuthKey))
forall a. STM a -> IO a
atomically (STM (Either XFTPErrorType (FileRec, APublicAuthKey))
 -> IO (Either XFTPErrorType (FileRec, APublicAuthKey)))
-> STM (Either XFTPErrorType (FileRec, APublicAuthKey))
-> IO (Either XFTPErrorType (FileRec, APublicAuthKey))
forall a b. (a -> b) -> a -> b
$ case SFileParty p
party of
    SFileParty p
SFSender -> STMFileStore
-> SenderId
-> (FileRec
    -> STM (Either XFTPErrorType (FileRec, APublicAuthKey)))
-> STM (Either XFTPErrorType (FileRec, APublicAuthKey))
forall a.
STMFileStore
-> SenderId
-> (FileRec -> STM (Either XFTPErrorType a))
-> STM (Either XFTPErrorType a)
withFile STMFileStore
st SenderId
fId ((FileRec -> STM (Either XFTPErrorType (FileRec, APublicAuthKey)))
 -> STM (Either XFTPErrorType (FileRec, APublicAuthKey)))
-> (FileRec
    -> STM (Either XFTPErrorType (FileRec, APublicAuthKey)))
-> STM (Either XFTPErrorType (FileRec, APublicAuthKey))
forall a b. (a -> b) -> a -> b
$ Either XFTPErrorType (FileRec, APublicAuthKey)
-> STM (Either XFTPErrorType (FileRec, APublicAuthKey))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either XFTPErrorType (FileRec, APublicAuthKey)
 -> STM (Either XFTPErrorType (FileRec, APublicAuthKey)))
-> (FileRec -> Either XFTPErrorType (FileRec, APublicAuthKey))
-> FileRec
-> STM (Either XFTPErrorType (FileRec, APublicAuthKey))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FileRec, APublicAuthKey)
-> Either XFTPErrorType (FileRec, APublicAuthKey)
forall a b. b -> Either a b
Right ((FileRec, APublicAuthKey)
 -> Either XFTPErrorType (FileRec, APublicAuthKey))
-> (FileRec -> (FileRec, APublicAuthKey))
-> FileRec
-> Either XFTPErrorType (FileRec, APublicAuthKey)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\FileRec
f -> (FileRec
f, FileInfo -> APublicAuthKey
sndKey (FileInfo -> APublicAuthKey) -> FileInfo -> APublicAuthKey
forall a b. (a -> b) -> a -> b
$ FileRec -> FileInfo
fileInfo FileRec
f))
    SFileParty p
SFRecipient ->
      SenderId
-> TMap SenderId (SenderId, APublicAuthKey)
-> STM (Maybe (SenderId, APublicAuthKey))
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookup SenderId
fId (STMFileStore -> TMap SenderId (SenderId, APublicAuthKey)
recipients STMFileStore
st) STM (Maybe (SenderId, APublicAuthKey))
-> (Maybe (SenderId, APublicAuthKey)
    -> STM (Either XFTPErrorType (FileRec, APublicAuthKey)))
-> STM (Either XFTPErrorType (FileRec, APublicAuthKey))
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just (SenderId
sId, APublicAuthKey
rKey) -> STMFileStore
-> SenderId
-> (FileRec
    -> STM (Either XFTPErrorType (FileRec, APublicAuthKey)))
-> STM (Either XFTPErrorType (FileRec, APublicAuthKey))
forall a.
STMFileStore
-> SenderId
-> (FileRec -> STM (Either XFTPErrorType a))
-> STM (Either XFTPErrorType a)
withFile STMFileStore
st SenderId
sId ((FileRec -> STM (Either XFTPErrorType (FileRec, APublicAuthKey)))
 -> STM (Either XFTPErrorType (FileRec, APublicAuthKey)))
-> (FileRec
    -> STM (Either XFTPErrorType (FileRec, APublicAuthKey)))
-> STM (Either XFTPErrorType (FileRec, APublicAuthKey))
forall a b. (a -> b) -> a -> b
$ Either XFTPErrorType (FileRec, APublicAuthKey)
-> STM (Either XFTPErrorType (FileRec, APublicAuthKey))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either XFTPErrorType (FileRec, APublicAuthKey)
 -> STM (Either XFTPErrorType (FileRec, APublicAuthKey)))
-> (FileRec -> Either XFTPErrorType (FileRec, APublicAuthKey))
-> FileRec
-> STM (Either XFTPErrorType (FileRec, APublicAuthKey))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FileRec, APublicAuthKey)
-> Either XFTPErrorType (FileRec, APublicAuthKey)
forall a b. b -> Either a b
Right ((FileRec, APublicAuthKey)
 -> Either XFTPErrorType (FileRec, APublicAuthKey))
-> (FileRec -> (FileRec, APublicAuthKey))
-> FileRec
-> Either XFTPErrorType (FileRec, APublicAuthKey)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,APublicAuthKey
rKey)
        Maybe (SenderId, APublicAuthKey)
_ -> Either XFTPErrorType (FileRec, APublicAuthKey)
-> STM (Either XFTPErrorType (FileRec, APublicAuthKey))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either XFTPErrorType (FileRec, APublicAuthKey)
 -> STM (Either XFTPErrorType (FileRec, APublicAuthKey)))
-> Either XFTPErrorType (FileRec, APublicAuthKey)
-> STM (Either XFTPErrorType (FileRec, APublicAuthKey))
forall a b. (a -> b) -> a -> b
$ XFTPErrorType -> Either XFTPErrorType (FileRec, APublicAuthKey)
forall a b. a -> Either a b
Left XFTPErrorType
AUTH

  ackFile :: STMFileStore -> SenderId -> IO (Either XFTPErrorType ())
ackFile st :: STMFileStore
st@STMFileStore {TMap SenderId (SenderId, APublicAuthKey)
recipients :: STMFileStore -> TMap SenderId (SenderId, APublicAuthKey)
recipients :: TMap SenderId (SenderId, APublicAuthKey)
recipients} SenderId
recipientId = STM (Either XFTPErrorType ()) -> IO (Either XFTPErrorType ())
forall a. STM a -> IO a
atomically (STM (Either XFTPErrorType ()) -> IO (Either XFTPErrorType ()))
-> STM (Either XFTPErrorType ()) -> IO (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ do
    SenderId
-> TMap SenderId (SenderId, APublicAuthKey)
-> STM (Maybe (SenderId, APublicAuthKey))
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookupDelete SenderId
recipientId TMap SenderId (SenderId, APublicAuthKey)
recipients STM (Maybe (SenderId, APublicAuthKey))
-> (Maybe (SenderId, APublicAuthKey)
    -> STM (Either XFTPErrorType ()))
-> STM (Either XFTPErrorType ())
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just (SenderId
sId, APublicAuthKey
_) ->
        STMFileStore
-> SenderId
-> (FileRec -> STM (Either XFTPErrorType ()))
-> STM (Either XFTPErrorType ())
forall a.
STMFileStore
-> SenderId
-> (FileRec -> STM (Either XFTPErrorType a))
-> STM (Either XFTPErrorType a)
withFile STMFileStore
st SenderId
sId ((FileRec -> STM (Either XFTPErrorType ()))
 -> STM (Either XFTPErrorType ()))
-> (FileRec -> STM (Either XFTPErrorType ()))
-> STM (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ \FileRec {TVar (Set SenderId)
recipientIds :: FileRec -> TVar (Set SenderId)
recipientIds :: TVar (Set SenderId)
recipientIds} -> do
          TVar (Set SenderId) -> (Set SenderId -> Set SenderId) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (Set SenderId)
recipientIds ((Set SenderId -> Set SenderId) -> STM ())
-> (Set SenderId -> Set SenderId) -> STM ()
forall a b. (a -> b) -> a -> b
$ SenderId -> Set SenderId -> Set SenderId
forall a. Ord a => a -> Set a -> Set a
S.delete SenderId
recipientId
          Either XFTPErrorType () -> STM (Either XFTPErrorType ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either XFTPErrorType () -> STM (Either XFTPErrorType ()))
-> Either XFTPErrorType () -> STM (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ () -> Either XFTPErrorType ()
forall a b. b -> Either a b
Right ()
      Maybe (SenderId, APublicAuthKey)
_ -> Either XFTPErrorType () -> STM (Either XFTPErrorType ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either XFTPErrorType () -> STM (Either XFTPErrorType ()))
-> Either XFTPErrorType () -> STM (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ XFTPErrorType -> Either XFTPErrorType ()
forall a b. a -> Either a b
Left XFTPErrorType
AUTH

  expiredFiles :: STMFileStore
-> Int64 -> Int -> IO [(SenderId, Maybe FilePath, Word32)]
expiredFiles STMFileStore {TMap SenderId FileRec
files :: STMFileStore -> TMap SenderId FileRec
files :: TMap SenderId FileRec
files} Int64
old Int
_limit = do
    Map SenderId FileRec
fs <- TMap SenderId FileRec -> IO (Map SenderId FileRec)
forall a. TVar a -> IO a
readTVarIO TMap SenderId FileRec
files
    ([Maybe (SenderId, Maybe FilePath, Word32)]
 -> [(SenderId, Maybe FilePath, Word32)])
-> IO [Maybe (SenderId, Maybe FilePath, Word32)]
-> IO [(SenderId, Maybe FilePath, Word32)]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe (SenderId, Maybe FilePath, Word32)]
-> [(SenderId, Maybe FilePath, Word32)]
forall a. [Maybe a] -> [a]
catMaybes (IO [Maybe (SenderId, Maybe FilePath, Word32)]
 -> IO [(SenderId, Maybe FilePath, Word32)])
-> (((SenderId, FileRec)
     -> IO (Maybe (SenderId, Maybe FilePath, Word32)))
    -> IO [Maybe (SenderId, Maybe FilePath, Word32)])
-> ((SenderId, FileRec)
    -> IO (Maybe (SenderId, Maybe FilePath, Word32)))
-> IO [(SenderId, Maybe FilePath, Word32)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SenderId, FileRec)]
-> ((SenderId, FileRec)
    -> IO (Maybe (SenderId, Maybe FilePath, Word32)))
-> IO [Maybe (SenderId, Maybe FilePath, Word32)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map SenderId FileRec -> [(SenderId, FileRec)]
forall k a. Map k a -> [(k, a)]
M.toList Map SenderId FileRec
fs) (((SenderId, FileRec)
  -> IO (Maybe (SenderId, Maybe FilePath, Word32)))
 -> IO [(SenderId, Maybe FilePath, Word32)])
-> ((SenderId, FileRec)
    -> IO (Maybe (SenderId, Maybe FilePath, Word32)))
-> IO [(SenderId, Maybe FilePath, Word32)]
forall a b. (a -> b) -> a -> b
$ \(SenderId
sId, FileRec {fileInfo :: FileRec -> FileInfo
fileInfo = FileInfo {Word32
size :: Word32
size :: FileInfo -> Word32
size}, TVar (Maybe FilePath)
filePath :: FileRec -> TVar (Maybe FilePath)
filePath :: TVar (Maybe FilePath)
filePath, createdAt :: FileRec -> RoundedFileTime
createdAt = RoundedSystemTime Int64
createdAt}) ->
      if Int64
createdAt Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
fileTimePrecision Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
old
        then do
          Maybe FilePath
path <- TVar (Maybe FilePath) -> IO (Maybe FilePath)
forall a. TVar a -> IO a
readTVarIO TVar (Maybe FilePath)
filePath
          Maybe (SenderId, Maybe FilePath, Word32)
-> IO (Maybe (SenderId, Maybe FilePath, Word32))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (SenderId, Maybe FilePath, Word32)
 -> IO (Maybe (SenderId, Maybe FilePath, Word32)))
-> Maybe (SenderId, Maybe FilePath, Word32)
-> IO (Maybe (SenderId, Maybe FilePath, Word32))
forall a b. (a -> b) -> a -> b
$ (SenderId, Maybe FilePath, Word32)
-> Maybe (SenderId, Maybe FilePath, Word32)
forall a. a -> Maybe a
Just (SenderId
sId, Maybe FilePath
path, Word32
size)
        else Maybe (SenderId, Maybe FilePath, Word32)
-> IO (Maybe (SenderId, Maybe FilePath, Word32))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (SenderId, Maybe FilePath, Word32)
forall a. Maybe a
Nothing

  getUsedStorage :: STMFileStore -> IO Int64
getUsedStorage STMFileStore {TMap SenderId FileRec
files :: STMFileStore -> TMap SenderId FileRec
files :: TMap SenderId FileRec
files} =
    (Int64 -> FileRec -> Int64)
-> Int64 -> Map SenderId FileRec -> Int64
forall a b k. (a -> b -> a) -> a -> Map k b -> a
M.foldl' (\Int64
acc FileRec {fileInfo :: FileRec -> FileInfo
fileInfo = FileInfo {Word32
size :: FileInfo -> Word32
size :: Word32
size}} -> Int64
acc Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Word32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
size) Int64
0 (Map SenderId FileRec -> Int64)
-> IO (Map SenderId FileRec) -> IO Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMap SenderId FileRec -> IO (Map SenderId FileRec)
forall a. TVar a -> IO a
readTVarIO TMap SenderId FileRec
files

  getFileCount :: STMFileStore -> IO Int
getFileCount STMFileStore {TMap SenderId FileRec
files :: STMFileStore -> TMap SenderId FileRec
files :: TMap SenderId FileRec
files} = Map SenderId FileRec -> Int
forall k a. Map k a -> Int
M.size (Map SenderId FileRec -> Int)
-> IO (Map SenderId FileRec) -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMap SenderId FileRec -> IO (Map SenderId FileRec)
forall a. TVar a -> IO a
readTVarIO TMap SenderId FileRec
files

-- Internal STM helpers

newFileRec :: SenderId -> FileInfo -> RoundedFileTime -> ServerEntityStatus -> STM FileRec
newFileRec :: SenderId
-> FileInfo -> RoundedFileTime -> ServerEntityStatus -> STM FileRec
newFileRec SenderId
senderId FileInfo
fileInfo RoundedFileTime
createdAt ServerEntityStatus
status = do
  TVar (Set SenderId)
recipientIds <- Set SenderId -> STM (TVar (Set SenderId))
forall a. a -> STM (TVar a)
newTVar Set SenderId
forall a. Set a
S.empty
  TVar (Maybe FilePath)
filePath <- Maybe FilePath -> STM (TVar (Maybe FilePath))
forall a. a -> STM (TVar a)
newTVar Maybe FilePath
forall a. Maybe a
Nothing
  TVar ServerEntityStatus
fileStatus <- ServerEntityStatus -> STM (TVar ServerEntityStatus)
forall a. a -> STM (TVar a)
newTVar ServerEntityStatus
status
  FileRec -> STM FileRec
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FileRec {SenderId
senderId :: SenderId
senderId :: SenderId
senderId, FileInfo
fileInfo :: FileInfo
fileInfo :: FileInfo
fileInfo, TVar (Maybe FilePath)
filePath :: TVar (Maybe FilePath)
filePath :: TVar (Maybe FilePath)
filePath, TVar (Set SenderId)
recipientIds :: TVar (Set SenderId)
recipientIds :: TVar (Set SenderId)
recipientIds, RoundedFileTime
createdAt :: RoundedFileTime
createdAt :: RoundedFileTime
createdAt, TVar ServerEntityStatus
fileStatus :: TVar ServerEntityStatus
fileStatus :: TVar ServerEntityStatus
fileStatus}

withFile :: STMFileStore -> SenderId -> (FileRec -> STM (Either XFTPErrorType a)) -> STM (Either XFTPErrorType a)
withFile :: forall a.
STMFileStore
-> SenderId
-> (FileRec -> STM (Either XFTPErrorType a))
-> STM (Either XFTPErrorType a)
withFile STMFileStore {TMap SenderId FileRec
files :: STMFileStore -> TMap SenderId FileRec
files :: TMap SenderId FileRec
files} SenderId
sId FileRec -> STM (Either XFTPErrorType a)
a =
  SenderId -> TMap SenderId FileRec -> STM (Maybe FileRec)
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookup SenderId
sId TMap SenderId FileRec
files STM (Maybe FileRec)
-> (Maybe FileRec -> STM (Either XFTPErrorType a))
-> STM (Either XFTPErrorType a)
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just FileRec
f -> FileRec -> STM (Either XFTPErrorType a)
a FileRec
f
    Maybe FileRec
_ -> Either XFTPErrorType a -> STM (Either XFTPErrorType a)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either XFTPErrorType a -> STM (Either XFTPErrorType a))
-> Either XFTPErrorType a -> STM (Either XFTPErrorType a)
forall a b. (a -> b) -> a -> b
$ XFTPErrorType -> Either XFTPErrorType a
forall a b. a -> Either a b
Left XFTPErrorType
AUTH