mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-06-03 08:47:32 +00:00
Evgeny
4dc40bd795
* smp server: queue store typeclass * parameterize JournalMsgStore * typeclass for queue store * postgres WIP * compiles, passes tests * remove StoreType * split migrations * progress * addQueueRec * reduce type spaghetti * remove addQueue from typeclass definition * getQueue * test postgres storage in SMP server * fix schema * comment * import queues to postgresql * import queues to postgresql * log * fix test * counts * ci: test smp server with postgres backend (#1463) * ci: test smp server with postgres backend * postgres service * attempt * attempt * empty * empty * PGHOST attempt * PGHOST + softlink attempt * only softlink attempt * working attempt (PGHOST) * remove env var * empty * do not start server without DB schema, do not import when schema exists * export database * enable all tests, disable two tests * option for migration confirmation * comments --------- Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
82 lines
2.6 KiB
Haskell
82 lines
2.6 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DerivingStrategies #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE KindSignatures #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Simplex.Messaging.Server.QueueStore where
|
|
|
|
import Control.Applicative ((<|>))
|
|
import Data.Functor (($>))
|
|
import Data.Int (Int64)
|
|
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
|
import Data.Time.Clock.System (SystemTime (..), getSystemTime)
|
|
import Database.PostgreSQL.Simple.FromField (FromField (..))
|
|
import Database.PostgreSQL.Simple.ToField (ToField (..))
|
|
import Simplex.Messaging.Agent.Store.Postgres.DB (fromTextField_)
|
|
import Simplex.Messaging.Encoding.String
|
|
import Simplex.Messaging.Protocol
|
|
import Simplex.Messaging.Util (eitherToMaybe)
|
|
|
|
data QueueRec = QueueRec
|
|
{ recipientKey :: !RcvPublicAuthKey,
|
|
rcvDhSecret :: !RcvDhSecret,
|
|
senderId :: !SenderId,
|
|
senderKey :: !(Maybe SndPublicAuthKey),
|
|
sndSecure :: !SenderCanSecure,
|
|
notifier :: !(Maybe NtfCreds),
|
|
status :: !ServerEntityStatus,
|
|
updatedAt :: !(Maybe RoundedSystemTime)
|
|
}
|
|
deriving (Show)
|
|
|
|
data NtfCreds = NtfCreds
|
|
{ notifierId :: !NotifierId,
|
|
notifierKey :: !NtfPublicAuthKey,
|
|
rcvNtfDhSecret :: !RcvNtfDhSecret
|
|
}
|
|
deriving (Show)
|
|
|
|
instance StrEncoding NtfCreds where
|
|
strEncode NtfCreds {notifierId, notifierKey, rcvNtfDhSecret} = strEncode (notifierId, notifierKey, rcvNtfDhSecret)
|
|
strP = do
|
|
(notifierId, notifierKey, rcvNtfDhSecret) <- strP
|
|
pure NtfCreds {notifierId, notifierKey, rcvNtfDhSecret}
|
|
|
|
data ServerEntityStatus
|
|
= EntityActive
|
|
| EntityBlocked BlockingInfo
|
|
| EntityOff
|
|
deriving (Eq, Show)
|
|
|
|
instance StrEncoding ServerEntityStatus where
|
|
strEncode = \case
|
|
EntityActive -> "active"
|
|
EntityBlocked info -> "blocked," <> strEncode info
|
|
EntityOff -> "off"
|
|
strP =
|
|
"active" $> EntityActive
|
|
<|> "blocked," *> (EntityBlocked <$> strP)
|
|
<|> "off" $> EntityOff
|
|
|
|
instance FromField ServerEntityStatus where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
|
|
|
|
instance ToField ServerEntityStatus where toField = toField . decodeLatin1 . strEncode
|
|
|
|
newtype RoundedSystemTime = RoundedSystemTime Int64
|
|
deriving (Eq, Ord, Show)
|
|
deriving newtype (FromField, ToField)
|
|
|
|
instance StrEncoding RoundedSystemTime where
|
|
strEncode (RoundedSystemTime t) = strEncode t
|
|
strP = RoundedSystemTime <$> strP
|
|
|
|
getRoundedSystemTime :: Int64 -> IO RoundedSystemTime
|
|
getRoundedSystemTime prec = (\t -> RoundedSystemTime $ (systemSeconds t `div` prec) * prec) <$> getSystemTime
|
|
|
|
getSystemDate :: IO RoundedSystemTime
|
|
getSystemDate = getRoundedSystemTime 86400
|