more fixes

src/Simplex/FileTransfer/Agent.hs

@@ -69,7 +69,6 @@ import Simplex.Messaging.Agent.Stats
 import Simplex.Messaging.Agent.Store.AgentStore
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential)
 import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs)
 import qualified Simplex.Messaging.Crypto.File as CF
 import qualified Simplex.Messaging.Crypto.Lazy as LC
@@ -580,7 +579,7 @@ runXFTPSndWorker c srv Worker {doWork} = do
               replicas = [FileChunkReplica {server, replicaId, replicaKey}]
           pure FileChunk {chunkNo, digest = chDigest, chunkSize, replicas}
         sndFileExpiresAt :: [SndFileChunk] -> Maybe GrantedStorageTime
-        sndFileExpiresAt = fmap minimum . mapM chunkExpiresAt
+        sndFileExpiresAt chunks' = fmap minimum $ L.nonEmpty =<< mapM chunkExpiresAt chunks'
           where
             chunkExpiresAt SndFileChunk {replicas} = maximum <$> L.nonEmpty (mapMaybe (\SndFileChunkReplica {expiresAt} -> expiresAt) replicas)
         createRcvFileDescriptions :: FileDescription 'FRecipient -> [SndFileChunk] -> [FileDescription 'FRecipient]

src/Simplex/FileTransfer/Server.hs

@@ -30,8 +30,8 @@ import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty)
-import qualified Data.Map.Strict as M
 import qualified Data.List.NonEmpty as L
+import qualified Data.Map.Strict as M
 import Data.Maybe (fromMaybe, isJust)
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
@@ -57,7 +57,7 @@ import Simplex.FileTransfer.Server.StoreLog
 import Simplex.FileTransfer.Transport
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.BBS (BBSPresHeader (..))
-import Simplex.Messaging.Crypto.Entitlement (Entitlement (..), EntitlementProof (..), verifyEntitlement)
+import Simplex.Messaging.Crypto.Entitlement (Entitlement (..), EntitlementProof (..), EntitlementVerification (..), verifyEntitlement)
 import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
@@ -241,7 +241,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
               Just cfg | entitlementValid now expiresAt -> do
                 keys <- asks $ entitlementKeys . config
                 liftIO (verifyEntitlement keys (BBSPresHeader sessionId) proof) >>= \case
-                  Just True -> pure $ Just SessionEntitlement {expiresAt, entConfig = cfg}
+                  EVValid -> pure $ Just SessionEntitlement {expiresAt, entConfig = cfg}
                   r -> Nothing <$ logError ("entitlement not verified: " <> tshow r)
               _ -> pure Nothing
         sendError :: XFTPErrorType -> M s (Maybe (THandleParams XFTPVersion 'TServer))

src/Simplex/FileTransfer/Server/Env.hs

@@ -46,7 +46,6 @@ import Data.X509.Validation (Fingerprint (..))
 import Network.Socket
 import qualified Network.TLS as T
 import Simplex.FileTransfer.Protocol (FileCmd, FileInfo (..), XFTPFileId)
-import Simplex.Messaging.Crypto.BBS (BBSPublicKey)
 import Simplex.FileTransfer.Server.Stats
 import Data.Either (fromRight)
 import Data.Ini (Ini, lookupValue)
@@ -66,6 +65,7 @@ import System.Directory (doesFileExist)
 import Simplex.FileTransfer.Server.StoreLog
 import Simplex.FileTransfer.Transport (VersionRangeXFTP)
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.BBS (BBSPublicKey)
 import Simplex.Messaging.Protocol (BasicAuth, RcvPublicAuthKey)
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Transport (EntitlementConfig (..))

src/Simplex/Messaging/Agent/Client.hs

@@ -255,7 +255,7 @@ import qualified Simplex.Messaging.Agent.TSessionSubs as SS
 import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.BBS (BBSPresHeader (..), BBSPublicKey)
-import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential (..), EntitlementProof, generateEntitlementProof)
+import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential, EntitlementProof, generateEntitlementProof)
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Client
@@ -901,10 +901,8 @@ getXFTPServerClient c@AgentClient {active, xftpClients, userEntitlements, worker
 
     mkEntitlementProof :: Map Word16 BBSPublicKey -> SessionId -> IO (Maybe EntitlementProof)
     mkEntitlementProof keys sessId =
-      TM.lookupIO userId userEntitlements
-        $>>= \cred -> pure (M.lookup (issuerKeyIdx cred) keys)
-        $>>= \pk -> generateEntitlementProof pk cred (BBSPresHeader sessId)
-        >>= \case
+      TM.lookupIO userId userEntitlements $>>= \cred ->
+        generateEntitlementProof keys cred (BBSPresHeader sessId) >>= \case
           Right p -> pure $ Just p
           Left e -> Nothing <$ logError ("entitlement proof error: " <> tshow e)
 

src/Simplex/Messaging/Agent/Store/AgentStore.hs

@@ -3660,7 +3660,7 @@ getNextSndChunkToUpload db server@ProtocolServer {host, port, keyHash} ttl = do
               SELECT
                 f.snd_file_id, f.snd_file_entity_id, f.user_id, f.num_recipients, f.prefix_path,
                 c.snd_file_chunk_id, c.chunk_no, c.chunk_offset, c.chunk_size, c.digest,
-                r.snd_file_chunk_replica_id, r.replica_id, r.replica_key, r.replica_status, r.delay, r.retries
+                r.snd_file_chunk_replica_id, r.replica_id, r.replica_key, r.replica_status, r.delay, r.retries, r.replica_expires_at
               FROM snd_file_chunk_replicas r
               JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id
               JOIN snd_file_chunks c ON c.snd_file_chunk_id = r.snd_file_chunk_id
@@ -3674,8 +3674,8 @@ getNextSndChunkToUpload db server@ProtocolServer {host, port, keyHash} ttl = do
           pure (replica :: SndFileChunkReplica) {rcvIdsKeys}
         pure (chunk {replicas = replicas'} :: SndFileChunk)
       where
-        toChunk :: ((DBSndFileId, SndFileId, UserId, Int, FilePath) :. (Int64, Int, Int64, Word32, FileDigest) :. (Int64, ChunkReplicaId, C.APrivateAuthKey, SndFileReplicaStatus, Maybe Int64, Int)) -> SndFileChunk
-        toChunk ((sndFileId, sndFileEntityId, userId, numRecipients, filePrefixPath) :. (sndChunkId, chunkNo, chunkOffset, chunkSize, digest) :. (sndChunkReplicaId, replicaId, replicaKey, replicaStatus, delay, retries)) =
+        toChunk :: ((DBSndFileId, SndFileId, UserId, Int, FilePath) :. (Int64, Int, Int64, Word32, FileDigest) :. (Int64, ChunkReplicaId, C.APrivateAuthKey, SndFileReplicaStatus, Maybe Int64, Int, Maybe Int64)) -> SndFileChunk
+        toChunk ((sndFileId, sndFileEntityId, userId, numRecipients, filePrefixPath) :. (sndChunkId, chunkNo, chunkOffset, chunkSize, digest) :. (sndChunkReplicaId, replicaId, replicaKey, replicaStatus, delay, retries, expiresAtSec)) =
           let chunkSpec = XFTPChunkSpec {filePath = sndFileEncPath filePrefixPath, chunkOffset, chunkSize}
            in SndFileChunk
                 { sndFileId,
@@ -3687,7 +3687,7 @@ getNextSndChunkToUpload db server@ProtocolServer {host, port, keyHash} ttl = do
                   chunkSpec,
                   digest,
                   filePrefixPath,
-                  replicas = [SndFileChunkReplica {sndChunkReplicaId, server, replicaId, replicaKey, replicaStatus, delay, retries, expiresAt = Nothing, rcvIdsKeys = []}]
+                  replicas = [SndFileChunkReplica {sndChunkReplicaId, server, replicaId, replicaKey, replicaStatus, delay, retries, expiresAt = GSTExpires <$> expiresAtSec, rcvIdsKeys = []}]
                 }
 
 updateSndChunkReplicaDelay :: DB.Connection -> Int64 -> Int64 -> IO ()

src/Simplex/Messaging/Crypto/Entitlement.hs

@@ -10,6 +10,7 @@ module Simplex.Messaging.Crypto.Entitlement
   ( Entitlement (..),
     EntitlementCredential (..),
     EntitlementProof (..),
+    EntitlementVerification (..),
     MasterKey (..),
     randomMasterKey,
     entitlementBBSHeader,
@@ -22,7 +23,6 @@ module Simplex.Messaging.Crypto.Entitlement
 where
 
 import Control.Concurrent.STM
-import Control.Monad (forM)
 import Crypto.Random (ChaChaDRG)
 import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Aeson.TH as JQ
@@ -48,8 +48,8 @@ newtype MasterKey = MasterKey ByteString
   deriving (ToJSON, FromJSON) via (StrJSON "MasterKey" MasterKey)
 
 data Entitlement = Entitlement
-  { entitlementName :: Text,
-    expiresAt :: UTCTime,
+  { expiresAt :: UTCTime,
+    entitlementName :: Text,
     extraInfo :: Text
   }
   deriving (Eq, Show)
@@ -69,14 +69,17 @@ data EntitlementProof = EntitlementProof
   }
   deriving (Eq, Show)
 
+data EntitlementVerification = EVValid | EVInvalid | EVUnknownIssuer
+  deriving (Eq, Show)
+
 instance Encoding Entitlement where
-  smpEncode Entitlement {entitlementName, expiresAt, extraInfo} =
-    smpEncode (entitlementName, strEncode expiresAt, Large $ encodeUtf8 extraInfo)
+  smpEncode Entitlement {expiresAt, entitlementName, extraInfo} =
+    smpEncode (strEncode expiresAt, entitlementName, Large $ encodeUtf8 extraInfo)
   smpP = do
-    (entitlementName, expBs, Large extraBs) <- smpP
+    (expBs, entitlementName, Large extraBs) <- smpP
     expiresAt <- either fail pure $ strDecode (expBs :: ByteString)
     extraInfo <- either (fail . show) pure $ decodeUtf8' extraBs
-    pure Entitlement {entitlementName, expiresAt, extraInfo}
+    pure Entitlement {expiresAt, entitlementName, extraInfo}
 
 instance Encoding EntitlementProof where
   smpEncode EntitlementProof {issuerKeyIdx, entProof, entitlement} =
@@ -98,7 +101,7 @@ entitlementMessages :: MasterKey -> Entitlement -> [ByteString]
 entitlementMessages (MasterKey mk) ent = mk : disclosedMessages ent
 
 disclosedMessages :: Entitlement -> [ByteString]
-disclosedMessages Entitlement {entitlementName, expiresAt, extraInfo} =
+disclosedMessages Entitlement {expiresAt, entitlementName, extraInfo} =
   [strEncode expiresAt, encodeUtf8 entitlementName, encodeUtf8 extraInfo]
 
 randomMasterKey :: TVar ChaChaDRG -> STM MasterKey
@@ -112,14 +115,19 @@ verifyCredential :: BBSPublicKey -> EntitlementCredential -> IO Bool
 verifyCredential pk EntitlementCredential {masterKey, issuerSignature, entitlement} =
   bbsVerify pk issuerSignature entitlementBBSHeader (entitlementMessages masterKey entitlement)
 
-generateEntitlementProof :: BBSPublicKey -> EntitlementCredential -> BBSPresHeader -> IO (Either String EntitlementProof)
-generateEntitlementProof pk EntitlementCredential {issuerKeyIdx, masterKey, issuerSignature, entitlement} ph =
-  EntitlementProof issuerKeyIdx entitlement <$$> bbsProofGen pk issuerSignature entitlementBBSHeader ph entitlementDisclosedIndexes (entitlementMessages masterKey entitlement)
+generateEntitlementProof :: Map Word16 BBSPublicKey -> EntitlementCredential -> BBSPresHeader -> IO (Either String EntitlementProof)
+generateEntitlementProof keys EntitlementCredential {issuerKeyIdx, masterKey, issuerSignature, entitlement} ph =
+  case M.lookup issuerKeyIdx keys of
+    Nothing -> pure $ Left $ "no issuer key " <> show issuerKeyIdx
+    Just pk -> EntitlementProof issuerKeyIdx entitlement <$$> bbsProofGen pk issuerSignature entitlementBBSHeader ph entitlementDisclosedIndexes (entitlementMessages masterKey entitlement)
 
-verifyEntitlement :: Map Word16 BBSPublicKey -> BBSPresHeader -> EntitlementProof -> IO (Maybe Bool)
+verifyEntitlement :: Map Word16 BBSPublicKey -> BBSPresHeader -> EntitlementProof -> IO EntitlementVerification
 verifyEntitlement keys ph EntitlementProof {issuerKeyIdx, entProof, entitlement} =
-  forM (M.lookup issuerKeyIdx keys) $ \pk ->
-    bbsProofVerify pk entProof entitlementBBSHeader ph entitlementDisclosedIndexes entitlementMessageCount (disclosedMessages entitlement)
+  case M.lookup issuerKeyIdx keys of
+    Nothing -> pure EVUnknownIssuer
+    Just pk ->
+      (\valid -> if valid then EVValid else EVInvalid)
+        <$> bbsProofVerify pk entProof entitlementBBSHeader ph entitlementDisclosedIndexes entitlementMessageCount (disclosedMessages entitlement)
 
 entitlementIssuerKeys :: Map Word16 BBSPublicKey
 entitlementIssuerKeys =