{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Simplex.Messaging.Agent.Store.SQLite
  ( SQLiteStore (..),
    createSQLiteStore,
    connectSQLiteStore,
  )
where

import Control.Concurrent (threadDelay)
import Control.Monad (when)
import Control.Monad.Except (MonadError (throwError), MonadIO (liftIO))
import Control.Monad.IO.Unlift (MonadUnliftIO)
import Data.Bifunctor (first)
import Data.List (find)
import Data.Maybe (fromMaybe)
import Data.Text (isPrefixOf)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import Database.SQLite.Simple (FromRow, NamedParam (..), Only (..), SQLData (..), SQLError, field)
import qualified Database.SQLite.Simple as DB
import Database.SQLite.Simple.FromField
import Database.SQLite.Simple.Internal (Field (..))
import Database.SQLite.Simple.Ok (Ok (Ok))
import Database.SQLite.Simple.QQ (sql)
import Database.SQLite.Simple.ToField (ToField (..))
import Network.Socket (ServiceName)
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.Store
import Simplex.Messaging.Agent.Store.SQLite.Schema (createSchema)
import Simplex.Messaging.Parsers (blobFieldParser)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Util (bshow, liftIOEither)
import System.Exit (ExitCode (ExitFailure), exitWith)
import System.FilePath (takeDirectory)
import Text.Read (readMaybe)
import UnliftIO.Directory (createDirectoryIfMissing)
import qualified UnliftIO.Exception as E

-- * SQLite Store implementation

data SQLiteStore = SQLiteStore
  { SQLiteStore -> FilePath
dbFilePath :: FilePath,
    SQLiteStore -> Connection
dbConn :: DB.Connection
  }

createSQLiteStore :: MonadUnliftIO m => FilePath -> m SQLiteStore
createSQLiteStore :: FilePath -> m SQLiteStore
createSQLiteStore dbFilePath :: FilePath
dbFilePath = do
  let dbDir :: FilePath
dbDir = FilePath -> FilePath
takeDirectory FilePath
dbFilePath
  Bool -> FilePath -> m ()
forall (m :: * -> *). MonadIO m => Bool -> FilePath -> m ()
createDirectoryIfMissing Bool
False FilePath
dbDir
  SQLiteStore
store <- FilePath -> m SQLiteStore
forall (m :: * -> *). MonadUnliftIO m => FilePath -> m SQLiteStore
connectSQLiteStore FilePath
dbFilePath
  [[Text]]
compileOptions <- IO [[Text]] -> m [[Text]]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Connection -> Query -> IO [[Text]]
forall r. FromRow r => Connection -> Query -> IO [r]
DB.query_ (SQLiteStore -> Connection
dbConn SQLiteStore
store) "pragma COMPILE_OPTIONS;" :: IO [[T.Text]])
  let threadsafeOption :: Maybe Text
threadsafeOption = (Text -> Bool) -> [Text] -> Maybe Text
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Text -> Text -> Bool
isPrefixOf "THREADSAFE=") ([[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Text]]
compileOptions)
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ case Maybe Text
threadsafeOption of
    Just "THREADSAFE=0" -> do
      FilePath -> IO ()
putStrLn "SQLite compiled with not threadsafe code, continue (y/n):"
      FilePath
s <- IO FilePath
getLine
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath
s FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= "y") (ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO ()) -> ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure 2)
    Nothing -> FilePath -> IO ()
putStrLn "Warning: SQLite THREADSAFE compile option not found"
    _ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Connection -> IO ()) -> Connection -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection -> IO ()
createSchema (Connection -> m ()) -> Connection -> m ()
forall a b. (a -> b) -> a -> b
$ SQLiteStore -> Connection
dbConn SQLiteStore
store
  SQLiteStore -> m SQLiteStore
forall (m :: * -> *) a. Monad m => a -> m a
return SQLiteStore
store

connectSQLiteStore :: MonadUnliftIO m => FilePath -> m SQLiteStore
connectSQLiteStore :: FilePath -> m SQLiteStore
connectSQLiteStore dbFilePath :: FilePath
dbFilePath = do
  Connection
dbConn <- IO Connection -> m Connection
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Connection -> m Connection) -> IO Connection -> m Connection
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Connection
DB.open FilePath
dbFilePath
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
    Connection -> Query -> IO ()
DB.execute_
      Connection
dbConn
      [sql|
        PRAGMA foreign_keys = ON;
        PRAGMA journal_mode = WAL;
      |]
  SQLiteStore -> m SQLiteStore
forall (m :: * -> *) a. Monad m => a -> m a
return SQLiteStore :: FilePath -> Connection -> SQLiteStore
SQLiteStore {FilePath
dbFilePath :: FilePath
$sel:dbFilePath:SQLiteStore :: FilePath
dbFilePath, Connection
dbConn :: Connection
$sel:dbConn:SQLiteStore :: Connection
dbConn}

checkDuplicate :: (MonadUnliftIO m, MonadError StoreError m) => IO () -> m ()
checkDuplicate :: IO () -> m ()
checkDuplicate action :: IO ()
action = IO (Either StoreError ()) -> m ()
forall (m :: * -> *) e a.
(MonadIO m, MonadError e m) =>
IO (Either e a) -> m a
liftIOEither (IO (Either StoreError ()) -> m ())
-> IO (Either StoreError ()) -> m ()
forall a b. (a -> b) -> a -> b
$ (SQLError -> StoreError)
-> Either SQLError () -> Either StoreError ()
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first SQLError -> StoreError
handleError (Either SQLError () -> Either StoreError ())
-> IO (Either SQLError ()) -> IO (Either StoreError ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO () -> IO (Either SQLError ())
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
E.try IO ()
action
  where
    handleError :: SQLError -> StoreError
    handleError :: SQLError -> StoreError
handleError e :: SQLError
e
      | SQLError -> Error
DB.sqlError SQLError
e Error -> Error -> Bool
forall a. Eq a => a -> a -> Bool
== Error
DB.ErrorConstraint = StoreError
SEConnDuplicate
      | Bool
otherwise = ByteString -> StoreError
SEInternal (ByteString -> StoreError) -> ByteString -> StoreError
forall a b. (a -> b) -> a -> b
$ SQLError -> ByteString
forall a. Show a => a -> ByteString
bshow SQLError
e

withTransaction :: forall a. DB.Connection -> IO a -> IO a
withTransaction :: Connection -> IO a -> IO a
withTransaction db :: Connection
db a :: IO a
a = Int -> Int -> IO a
loop 100 100_000
  where
    loop :: Int -> Int -> IO a
    loop :: Int -> Int -> IO a
loop t :: Int
t tLim :: Int
tLim =
      Connection -> IO a -> IO a
forall a. Connection -> IO a -> IO a
DB.withImmediateTransaction Connection
db IO a
a IO a -> (SQLError -> IO a) -> IO a
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`E.catch` \(SQLError
e :: SQLError) ->
        if Int
tLim Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
t Bool -> Bool -> Bool
&& SQLError -> Error
DB.sqlError SQLError
e Error -> Error -> Bool
forall a. Eq a => a -> a -> Bool
== Error
DB.ErrorBusy
          then do
            Int -> IO ()
threadDelay Int
t
            Int -> Int -> IO a
loop (Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
* 9 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 8) (Int
tLim Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
t)
          else SQLError -> IO a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO SQLError
e

instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteStore m where
  createRcvConn :: SQLiteStore -> RcvQueue -> m ()
  createRcvConn :: SQLiteStore -> RcvQueue -> m ()
createRcvConn SQLiteStore {Connection
dbConn :: Connection
$sel:dbConn:SQLiteStore :: SQLiteStore -> Connection
dbConn} q :: RcvQueue
q@RcvQueue {SMPServer
$sel:server:RcvQueue :: RcvQueue -> SMPServer
server :: SMPServer
server} =
    IO () -> m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadError StoreError m) =>
IO () -> m ()
checkDuplicate (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
      Connection -> IO () -> IO ()
forall a. Connection -> IO a -> IO a
withTransaction Connection
dbConn (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Connection -> SMPServer -> IO ()
upsertServer_ Connection
dbConn SMPServer
server
        Connection -> RcvQueue -> IO ()
insertRcvQueue_ Connection
dbConn RcvQueue
q
        Connection -> RcvQueue -> IO ()
insertRcvConnection_ Connection
dbConn RcvQueue
q

  createSndConn :: SQLiteStore -> SndQueue -> m ()
  createSndConn :: SQLiteStore -> SndQueue -> m ()
createSndConn SQLiteStore {Connection
dbConn :: Connection
$sel:dbConn:SQLiteStore :: SQLiteStore -> Connection
dbConn} q :: SndQueue
q@SndQueue {SMPServer
$sel:server:SndQueue :: SndQueue -> SMPServer
server :: SMPServer
server} =
    IO () -> m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadError StoreError m) =>
IO () -> m ()
checkDuplicate (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
      Connection -> IO () -> IO ()
forall a. Connection -> IO a -> IO a
withTransaction Connection
dbConn (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Connection -> SMPServer -> IO ()
upsertServer_ Connection
dbConn SMPServer
server
        Connection -> SndQueue -> IO ()
insertSndQueue_ Connection
dbConn SndQueue
q
        Connection -> SndQueue -> IO ()
insertSndConnection_ Connection
dbConn SndQueue
q

  getConn :: SQLiteStore -> ConnAlias -> m SomeConn
  getConn :: SQLiteStore -> ByteString -> m SomeConn
getConn SQLiteStore {Connection
dbConn :: Connection
$sel:dbConn:SQLiteStore :: SQLiteStore -> Connection
dbConn} connAlias :: ByteString
connAlias =
    IO (Either StoreError SomeConn) -> m SomeConn
forall (m :: * -> *) e a.
(MonadIO m, MonadError e m) =>
IO (Either e a) -> m a
liftIOEither (IO (Either StoreError SomeConn) -> m SomeConn)
-> (IO (Either StoreError SomeConn)
    -> IO (Either StoreError SomeConn))
-> IO (Either StoreError SomeConn)
-> m SomeConn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection
-> IO (Either StoreError SomeConn)
-> IO (Either StoreError SomeConn)
forall a. Connection -> IO a -> IO a
withTransaction Connection
dbConn (IO (Either StoreError SomeConn) -> m SomeConn)
-> IO (Either StoreError SomeConn) -> m SomeConn
forall a b. (a -> b) -> a -> b
$
      Connection -> ByteString -> IO (Either StoreError SomeConn)
getConn_ Connection
dbConn ByteString
connAlias

  getAllConnAliases :: SQLiteStore -> m [ConnAlias]
  getAllConnAliases :: SQLiteStore -> m [ByteString]
getAllConnAliases SQLiteStore {Connection
dbConn :: Connection
$sel:dbConn:SQLiteStore :: SQLiteStore -> Connection
dbConn} =
    IO [ByteString] -> m [ByteString]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [ByteString] -> m [ByteString])
-> IO [ByteString] -> m [ByteString]
forall a b. (a -> b) -> a -> b
$ do
      [[ByteString]]
r <- Connection -> Query -> IO [[ByteString]]
forall r. FromRow r => Connection -> Query -> IO [r]
DB.query_ Connection
dbConn "SELECT conn_alias FROM connections;" :: IO [[ConnAlias]]
      [ByteString] -> IO [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[ByteString]] -> [ByteString]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[ByteString]]
r)

  getRcvConn :: SQLiteStore -> SMPServer -> SMP.RecipientId -> m SomeConn
  getRcvConn :: SQLiteStore -> SMPServer -> ByteString -> m SomeConn
getRcvConn SQLiteStore {Connection
dbConn :: Connection
$sel:dbConn:SQLiteStore :: SQLiteStore -> Connection
dbConn} SMPServer {FilePath
host :: SMPServer -> FilePath
host :: FilePath
host, Maybe FilePath
port :: SMPServer -> Maybe FilePath
port :: Maybe FilePath
port} rcvId :: ByteString
rcvId =
    IO (Either StoreError SomeConn) -> m SomeConn
forall (m :: * -> *) e a.
(MonadIO m, MonadError e m) =>
IO (Either e a) -> m a
liftIOEither (IO (Either StoreError SomeConn) -> m SomeConn)
-> (IO (Either StoreError SomeConn)
    -> IO (Either StoreError SomeConn))
-> IO (Either StoreError SomeConn)
-> m SomeConn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection
-> IO (Either StoreError SomeConn)
-> IO (Either StoreError SomeConn)
forall a. Connection -> IO a -> IO a
withTransaction Connection
dbConn (IO (Either StoreError SomeConn) -> m SomeConn)
-> IO (Either StoreError SomeConn) -> m SomeConn
forall a b. (a -> b) -> a -> b
$
      Connection -> Query -> [NamedParam] -> IO [Only ByteString]
forall r.
FromRow r =>
Connection -> Query -> [NamedParam] -> IO [r]
DB.queryNamed
        Connection
dbConn
        [sql|
          SELECT q.conn_alias
          FROM rcv_queues q
          WHERE q.host = :host AND q.port = :port AND q.rcv_id = :rcv_id;
        |]
        [":host" Text -> FilePath -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= FilePath
host, ":port" Text -> FilePath -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= Maybe FilePath -> FilePath
serializePort_ Maybe FilePath
port, ":rcv_id" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString
rcvId]
        IO [Only ByteString]
-> ([Only ByteString] -> IO (Either StoreError SomeConn))
-> IO (Either StoreError SomeConn)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          [Only connAlias :: ByteString
connAlias] -> Connection -> ByteString -> IO (Either StoreError SomeConn)
getConn_ Connection
dbConn ByteString
connAlias
          _ -> Either StoreError SomeConn -> IO (Either StoreError SomeConn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StoreError SomeConn -> IO (Either StoreError SomeConn))
-> Either StoreError SomeConn -> IO (Either StoreError SomeConn)
forall a b. (a -> b) -> a -> b
$ StoreError -> Either StoreError SomeConn
forall a b. a -> Either a b
Left StoreError
SEConnNotFound

  deleteConn :: SQLiteStore -> ConnAlias -> m ()
  deleteConn :: SQLiteStore -> ByteString -> m ()
deleteConn SQLiteStore {Connection
dbConn :: Connection
$sel:dbConn:SQLiteStore :: SQLiteStore -> Connection
dbConn} connAlias :: ByteString
connAlias =
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
      Connection -> Query -> [NamedParam] -> IO ()
DB.executeNamed
        Connection
dbConn
        "DELETE FROM connections WHERE conn_alias = :conn_alias;"
        [":conn_alias" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString
connAlias]

  upgradeRcvConnToDuplex :: SQLiteStore -> ConnAlias -> SndQueue -> m ()
  upgradeRcvConnToDuplex :: SQLiteStore -> ByteString -> SndQueue -> m ()
upgradeRcvConnToDuplex SQLiteStore {Connection
dbConn :: Connection
$sel:dbConn:SQLiteStore :: SQLiteStore -> Connection
dbConn} connAlias :: ByteString
connAlias sq :: SndQueue
sq@SndQueue {SMPServer
server :: SMPServer
$sel:server:SndQueue :: SndQueue -> SMPServer
server} =
    IO (Either StoreError ()) -> m ()
forall (m :: * -> *) e a.
(MonadIO m, MonadError e m) =>
IO (Either e a) -> m a
liftIOEither (IO (Either StoreError ()) -> m ())
-> (IO (Either StoreError ()) -> IO (Either StoreError ()))
-> IO (Either StoreError ())
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection
-> IO (Either StoreError ()) -> IO (Either StoreError ())
forall a. Connection -> IO a -> IO a
withTransaction Connection
dbConn (IO (Either StoreError ()) -> m ())
-> IO (Either StoreError ()) -> m ()
forall a b. (a -> b) -> a -> b
$
      Connection -> ByteString -> IO (Either StoreError SomeConn)
getConn_ Connection
dbConn ByteString
connAlias IO (Either StoreError SomeConn)
-> (Either StoreError SomeConn -> IO (Either StoreError ()))
-> IO (Either StoreError ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Right (SomeConn SCRcv (RcvConnection _ _)) -> do
          Connection -> SMPServer -> IO ()
upsertServer_ Connection
dbConn SMPServer
server
          Connection -> SndQueue -> IO ()
insertSndQueue_ Connection
dbConn SndQueue
sq
          Connection -> ByteString -> SndQueue -> IO ()
updateConnWithSndQueue_ Connection
dbConn ByteString
connAlias SndQueue
sq
          Either StoreError () -> IO (Either StoreError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StoreError () -> IO (Either StoreError ()))
-> Either StoreError () -> IO (Either StoreError ())
forall a b. (a -> b) -> a -> b
$ () -> Either StoreError ()
forall a b. b -> Either a b
Right ()
        Right (SomeConn c :: SConnType d
c _) -> Either StoreError () -> IO (Either StoreError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StoreError () -> IO (Either StoreError ()))
-> (ConnType -> Either StoreError ())
-> ConnType
-> IO (Either StoreError ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StoreError -> Either StoreError ()
forall a b. a -> Either a b
Left (StoreError -> Either StoreError ())
-> (ConnType -> StoreError) -> ConnType -> Either StoreError ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnType -> StoreError
SEBadConnType (ConnType -> IO (Either StoreError ()))
-> ConnType -> IO (Either StoreError ())
forall a b. (a -> b) -> a -> b
$ SConnType d -> ConnType
forall (c :: ConnType). SConnType c -> ConnType
connType SConnType d
c
        _ -> Either StoreError () -> IO (Either StoreError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StoreError () -> IO (Either StoreError ()))
-> Either StoreError () -> IO (Either StoreError ())
forall a b. (a -> b) -> a -> b
$ StoreError -> Either StoreError ()
forall a b. a -> Either a b
Left StoreError
SEConnNotFound

  upgradeSndConnToDuplex :: SQLiteStore -> ConnAlias -> RcvQueue -> m ()
  upgradeSndConnToDuplex :: SQLiteStore -> ByteString -> RcvQueue -> m ()
upgradeSndConnToDuplex SQLiteStore {Connection
dbConn :: Connection
$sel:dbConn:SQLiteStore :: SQLiteStore -> Connection
dbConn} connAlias :: ByteString
connAlias rq :: RcvQueue
rq@RcvQueue {SMPServer
server :: SMPServer
$sel:server:RcvQueue :: RcvQueue -> SMPServer
server} =
    IO (Either StoreError ()) -> m ()
forall (m :: * -> *) e a.
(MonadIO m, MonadError e m) =>
IO (Either e a) -> m a
liftIOEither (IO (Either StoreError ()) -> m ())
-> (IO (Either StoreError ()) -> IO (Either StoreError ()))
-> IO (Either StoreError ())
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection
-> IO (Either StoreError ()) -> IO (Either StoreError ())
forall a. Connection -> IO a -> IO a
withTransaction Connection
dbConn (IO (Either StoreError ()) -> m ())
-> IO (Either StoreError ()) -> m ()
forall a b. (a -> b) -> a -> b
$
      Connection -> ByteString -> IO (Either StoreError SomeConn)
getConn_ Connection
dbConn ByteString
connAlias IO (Either StoreError SomeConn)
-> (Either StoreError SomeConn -> IO (Either StoreError ()))
-> IO (Either StoreError ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Right (SomeConn SCSnd (SndConnection _ _)) -> do
          Connection -> SMPServer -> IO ()
upsertServer_ Connection
dbConn SMPServer
server
          Connection -> RcvQueue -> IO ()
insertRcvQueue_ Connection
dbConn RcvQueue
rq
          Connection -> ByteString -> RcvQueue -> IO ()
updateConnWithRcvQueue_ Connection
dbConn ByteString
connAlias RcvQueue
rq
          Either StoreError () -> IO (Either StoreError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StoreError () -> IO (Either StoreError ()))
-> Either StoreError () -> IO (Either StoreError ())
forall a b. (a -> b) -> a -> b
$ () -> Either StoreError ()
forall a b. b -> Either a b
Right ()
        Right (SomeConn c :: SConnType d
c _) -> Either StoreError () -> IO (Either StoreError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StoreError () -> IO (Either StoreError ()))
-> (ConnType -> Either StoreError ())
-> ConnType
-> IO (Either StoreError ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StoreError -> Either StoreError ()
forall a b. a -> Either a b
Left (StoreError -> Either StoreError ())
-> (ConnType -> StoreError) -> ConnType -> Either StoreError ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnType -> StoreError
SEBadConnType (ConnType -> IO (Either StoreError ()))
-> ConnType -> IO (Either StoreError ())
forall a b. (a -> b) -> a -> b
$ SConnType d -> ConnType
forall (c :: ConnType). SConnType c -> ConnType
connType SConnType d
c
        _ -> Either StoreError () -> IO (Either StoreError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StoreError () -> IO (Either StoreError ()))
-> Either StoreError () -> IO (Either StoreError ())
forall a b. (a -> b) -> a -> b
$ StoreError -> Either StoreError ()
forall a b. a -> Either a b
Left StoreError
SEConnNotFound

  setRcvQueueStatus :: SQLiteStore -> RcvQueue -> QueueStatus -> m ()
  setRcvQueueStatus :: SQLiteStore -> RcvQueue -> QueueStatus -> m ()
setRcvQueueStatus SQLiteStore {Connection
dbConn :: Connection
$sel:dbConn:SQLiteStore :: SQLiteStore -> Connection
dbConn} RcvQueue {ByteString
$sel:rcvId:RcvQueue :: RcvQueue -> ByteString
rcvId :: ByteString
rcvId, $sel:server:RcvQueue :: RcvQueue -> SMPServer
server = SMPServer {FilePath
host :: FilePath
host :: SMPServer -> FilePath
host, Maybe FilePath
port :: Maybe FilePath
port :: SMPServer -> Maybe FilePath
port}} status :: QueueStatus
status =
    -- ? throw error if queue doesn't exist?
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
      Connection -> Query -> [NamedParam] -> IO ()
DB.executeNamed
        Connection
dbConn
        [sql|
          UPDATE rcv_queues
          SET status = :status
          WHERE host = :host AND port = :port AND rcv_id = :rcv_id;
        |]
        [":status" Text -> QueueStatus -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= QueueStatus
status, ":host" Text -> FilePath -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= FilePath
host, ":port" Text -> FilePath -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= Maybe FilePath -> FilePath
serializePort_ Maybe FilePath
port, ":rcv_id" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString
rcvId]

  setRcvQueueActive :: SQLiteStore -> RcvQueue -> VerificationKey -> m ()
  setRcvQueueActive :: SQLiteStore -> RcvQueue -> VerificationKey -> m ()
setRcvQueueActive SQLiteStore {Connection
dbConn :: Connection
$sel:dbConn:SQLiteStore :: SQLiteStore -> Connection
dbConn} RcvQueue {ByteString
rcvId :: ByteString
$sel:rcvId:RcvQueue :: RcvQueue -> ByteString
rcvId, $sel:server:RcvQueue :: RcvQueue -> SMPServer
server = SMPServer {FilePath
host :: FilePath
host :: SMPServer -> FilePath
host, Maybe FilePath
port :: Maybe FilePath
port :: SMPServer -> Maybe FilePath
port}} verifyKey :: VerificationKey
verifyKey =
    -- ? throw error if queue doesn't exist?
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
      Connection -> Query -> [NamedParam] -> IO ()
DB.executeNamed
        Connection
dbConn
        [sql|
          UPDATE rcv_queues
          SET verify_key = :verify_key, status = :status
          WHERE host = :host AND port = :port AND rcv_id = :rcv_id;
        |]
        [ ":verify_key" Text -> Maybe VerificationKey -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= VerificationKey -> Maybe VerificationKey
forall a. a -> Maybe a
Just VerificationKey
verifyKey,
          ":status" Text -> QueueStatus -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= QueueStatus
Active,
          ":host" Text -> FilePath -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= FilePath
host,
          ":port" Text -> FilePath -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= Maybe FilePath -> FilePath
serializePort_ Maybe FilePath
port,
          ":rcv_id" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString
rcvId
        ]

  setSndQueueStatus :: SQLiteStore -> SndQueue -> QueueStatus -> m ()
  setSndQueueStatus :: SQLiteStore -> SndQueue -> QueueStatus -> m ()
setSndQueueStatus SQLiteStore {Connection
dbConn :: Connection
$sel:dbConn:SQLiteStore :: SQLiteStore -> Connection
dbConn} SndQueue {ByteString
$sel:sndId:SndQueue :: SndQueue -> ByteString
sndId :: ByteString
sndId, $sel:server:SndQueue :: SndQueue -> SMPServer
server = SMPServer {FilePath
host :: FilePath
host :: SMPServer -> FilePath
host, Maybe FilePath
port :: Maybe FilePath
port :: SMPServer -> Maybe FilePath
port}} status :: QueueStatus
status =
    -- ? throw error if queue doesn't exist?
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
      Connection -> Query -> [NamedParam] -> IO ()
DB.executeNamed
        Connection
dbConn
        [sql|
          UPDATE snd_queues
          SET status = :status
          WHERE host = :host AND port = :port AND snd_id = :snd_id;
        |]
        [":status" Text -> QueueStatus -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= QueueStatus
status, ":host" Text -> FilePath -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= FilePath
host, ":port" Text -> FilePath -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= Maybe FilePath -> FilePath
serializePort_ Maybe FilePath
port, ":snd_id" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString
sndId]

  updateRcvIds :: SQLiteStore -> RcvQueue -> m (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash)
  updateRcvIds :: SQLiteStore
-> RcvQueue
-> m (InternalId, InternalRcvId, PrevExternalSndId, ByteString)
updateRcvIds SQLiteStore {Connection
dbConn :: Connection
$sel:dbConn:SQLiteStore :: SQLiteStore -> Connection
dbConn} RcvQueue {ByteString
$sel:connAlias:RcvQueue :: RcvQueue -> ByteString
connAlias :: ByteString
connAlias} =
    IO (InternalId, InternalRcvId, PrevExternalSndId, ByteString)
-> m (InternalId, InternalRcvId, PrevExternalSndId, ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (InternalId, InternalRcvId, PrevExternalSndId, ByteString)
 -> m (InternalId, InternalRcvId, PrevExternalSndId, ByteString))
-> (IO (InternalId, InternalRcvId, PrevExternalSndId, ByteString)
    -> IO (InternalId, InternalRcvId, PrevExternalSndId, ByteString))
-> IO (InternalId, InternalRcvId, PrevExternalSndId, ByteString)
-> m (InternalId, InternalRcvId, PrevExternalSndId, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection
-> IO (InternalId, InternalRcvId, PrevExternalSndId, ByteString)
-> IO (InternalId, InternalRcvId, PrevExternalSndId, ByteString)
forall a. Connection -> IO a -> IO a
withTransaction Connection
dbConn (IO (InternalId, InternalRcvId, PrevExternalSndId, ByteString)
 -> m (InternalId, InternalRcvId, PrevExternalSndId, ByteString))
-> IO (InternalId, InternalRcvId, PrevExternalSndId, ByteString)
-> m (InternalId, InternalRcvId, PrevExternalSndId, ByteString)
forall a b. (a -> b) -> a -> b
$ do
      (lastInternalId :: InternalId
lastInternalId, lastInternalRcvId :: InternalRcvId
lastInternalRcvId, lastExternalSndId :: PrevExternalSndId
lastExternalSndId, lastRcvHash :: ByteString
lastRcvHash) <- Connection
-> ByteString
-> IO (InternalId, InternalRcvId, PrevExternalSndId, ByteString)
retrieveLastIdsAndHashRcv_ Connection
dbConn ByteString
connAlias
      let internalId :: InternalId
internalId = PrevExternalSndId -> InternalId
InternalId (PrevExternalSndId -> InternalId)
-> PrevExternalSndId -> InternalId
forall a b. (a -> b) -> a -> b
$ InternalId -> PrevExternalSndId
unId InternalId
lastInternalId PrevExternalSndId -> PrevExternalSndId -> PrevExternalSndId
forall a. Num a => a -> a -> a
+ 1
          internalRcvId :: InternalRcvId
internalRcvId = PrevExternalSndId -> InternalRcvId
InternalRcvId (PrevExternalSndId -> InternalRcvId)
-> PrevExternalSndId -> InternalRcvId
forall a b. (a -> b) -> a -> b
$ InternalRcvId -> PrevExternalSndId
unRcvId InternalRcvId
lastInternalRcvId PrevExternalSndId -> PrevExternalSndId -> PrevExternalSndId
forall a. Num a => a -> a -> a
+ 1
      Connection -> ByteString -> InternalId -> InternalRcvId -> IO ()
updateLastIdsRcv_ Connection
dbConn ByteString
connAlias InternalId
internalId InternalRcvId
internalRcvId
      (InternalId, InternalRcvId, PrevExternalSndId, ByteString)
-> IO (InternalId, InternalRcvId, PrevExternalSndId, ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InternalId
internalId, InternalRcvId
internalRcvId, PrevExternalSndId
lastExternalSndId, ByteString
lastRcvHash)

  createRcvMsg :: SQLiteStore -> RcvQueue -> RcvMsgData -> m ()
  createRcvMsg :: SQLiteStore -> RcvQueue -> RcvMsgData -> m ()
createRcvMsg SQLiteStore {Connection
dbConn :: Connection
$sel:dbConn:SQLiteStore :: SQLiteStore -> Connection
dbConn} RcvQueue {ByteString
connAlias :: ByteString
$sel:connAlias:RcvQueue :: RcvQueue -> ByteString
connAlias} rcvMsgData :: RcvMsgData
rcvMsgData =
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (IO () -> IO ()) -> IO () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection -> IO () -> IO ()
forall a. Connection -> IO a -> IO a
withTransaction Connection
dbConn (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      Connection -> ByteString -> RcvMsgData -> IO ()
insertRcvMsgBase_ Connection
dbConn ByteString
connAlias RcvMsgData
rcvMsgData
      Connection -> ByteString -> RcvMsgData -> IO ()
insertRcvMsgDetails_ Connection
dbConn ByteString
connAlias RcvMsgData
rcvMsgData
      Connection -> ByteString -> RcvMsgData -> IO ()
updateHashRcv_ Connection
dbConn ByteString
connAlias RcvMsgData
rcvMsgData

  updateSndIds :: SQLiteStore -> SndQueue -> m (InternalId, InternalSndId, PrevSndMsgHash)
  updateSndIds :: SQLiteStore
-> SndQueue -> m (InternalId, InternalSndId, ByteString)
updateSndIds SQLiteStore {Connection
dbConn :: Connection
$sel:dbConn:SQLiteStore :: SQLiteStore -> Connection
dbConn} SndQueue {ByteString
$sel:connAlias:SndQueue :: SndQueue -> ByteString
connAlias :: ByteString
connAlias} =
    IO (InternalId, InternalSndId, ByteString)
-> m (InternalId, InternalSndId, ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (InternalId, InternalSndId, ByteString)
 -> m (InternalId, InternalSndId, ByteString))
-> (IO (InternalId, InternalSndId, ByteString)
    -> IO (InternalId, InternalSndId, ByteString))
-> IO (InternalId, InternalSndId, ByteString)
-> m (InternalId, InternalSndId, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection
-> IO (InternalId, InternalSndId, ByteString)
-> IO (InternalId, InternalSndId, ByteString)
forall a. Connection -> IO a -> IO a
withTransaction Connection
dbConn (IO (InternalId, InternalSndId, ByteString)
 -> m (InternalId, InternalSndId, ByteString))
-> IO (InternalId, InternalSndId, ByteString)
-> m (InternalId, InternalSndId, ByteString)
forall a b. (a -> b) -> a -> b
$ do
      (lastInternalId :: InternalId
lastInternalId, lastInternalSndId :: InternalSndId
lastInternalSndId, prevSndHash :: ByteString
prevSndHash) <- Connection
-> ByteString -> IO (InternalId, InternalSndId, ByteString)
retrieveLastIdsAndHashSnd_ Connection
dbConn ByteString
connAlias
      let internalId :: InternalId
internalId = PrevExternalSndId -> InternalId
InternalId (PrevExternalSndId -> InternalId)
-> PrevExternalSndId -> InternalId
forall a b. (a -> b) -> a -> b
$ InternalId -> PrevExternalSndId
unId InternalId
lastInternalId PrevExternalSndId -> PrevExternalSndId -> PrevExternalSndId
forall a. Num a => a -> a -> a
+ 1
          internalSndId :: InternalSndId
internalSndId = PrevExternalSndId -> InternalSndId
InternalSndId (PrevExternalSndId -> InternalSndId)
-> PrevExternalSndId -> InternalSndId
forall a b. (a -> b) -> a -> b
$ InternalSndId -> PrevExternalSndId
unSndId InternalSndId
lastInternalSndId PrevExternalSndId -> PrevExternalSndId -> PrevExternalSndId
forall a. Num a => a -> a -> a
+ 1
      Connection -> ByteString -> InternalId -> InternalSndId -> IO ()
updateLastIdsSnd_ Connection
dbConn ByteString
connAlias InternalId
internalId InternalSndId
internalSndId
      (InternalId, InternalSndId, ByteString)
-> IO (InternalId, InternalSndId, ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InternalId
internalId, InternalSndId
internalSndId, ByteString
prevSndHash)

  createSndMsg :: SQLiteStore -> SndQueue -> SndMsgData -> m ()
  createSndMsg :: SQLiteStore -> SndQueue -> SndMsgData -> m ()
createSndMsg SQLiteStore {Connection
dbConn :: Connection
$sel:dbConn:SQLiteStore :: SQLiteStore -> Connection
dbConn} SndQueue {ByteString
connAlias :: ByteString
$sel:connAlias:SndQueue :: SndQueue -> ByteString
connAlias} sndMsgData :: SndMsgData
sndMsgData =
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (IO () -> IO ()) -> IO () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection -> IO () -> IO ()
forall a. Connection -> IO a -> IO a
withTransaction Connection
dbConn (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      Connection -> ByteString -> SndMsgData -> IO ()
insertSndMsgBase_ Connection
dbConn ByteString
connAlias SndMsgData
sndMsgData
      Connection -> ByteString -> SndMsgData -> IO ()
insertSndMsgDetails_ Connection
dbConn ByteString
connAlias SndMsgData
sndMsgData
      Connection -> ByteString -> SndMsgData -> IO ()
updateHashSnd_ Connection
dbConn ByteString
connAlias SndMsgData
sndMsgData

  getMsg :: SQLiteStore -> ConnAlias -> InternalId -> m Msg
  getMsg :: SQLiteStore -> ByteString -> InternalId -> m Msg
getMsg _st :: SQLiteStore
_st _connAlias :: ByteString
_connAlias _id :: InternalId
_id = StoreError -> m Msg
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError StoreError
SENotImplemented

-- * Auxiliary helpers

-- ? replace with ToField? - it's easy to forget to use this
serializePort_ :: Maybe ServiceName -> ServiceName
serializePort_ :: Maybe FilePath -> FilePath
serializePort_ = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe "_"

deserializePort_ :: ServiceName -> Maybe ServiceName
deserializePort_ :: FilePath -> Maybe FilePath
deserializePort_ "_" = Maybe FilePath
forall a. Maybe a
Nothing
deserializePort_ port :: FilePath
port = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
port

instance ToField QueueStatus where toField :: QueueStatus -> SQLData
toField = FilePath -> SQLData
forall a. ToField a => a -> SQLData
toField (FilePath -> SQLData)
-> (QueueStatus -> FilePath) -> QueueStatus -> SQLData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueueStatus -> FilePath
forall a. Show a => a -> FilePath
show

instance FromField QueueStatus where fromField :: FieldParser QueueStatus
fromField = FieldParser QueueStatus
forall a. (Read a, Typeable a) => Field -> Ok a
fromFieldToReadable_

instance ToField InternalRcvId where toField :: InternalRcvId -> SQLData
toField (InternalRcvId x :: PrevExternalSndId
x) = PrevExternalSndId -> SQLData
forall a. ToField a => a -> SQLData
toField PrevExternalSndId
x

instance FromField InternalRcvId where fromField :: FieldParser InternalRcvId
fromField x :: Field
x = PrevExternalSndId -> InternalRcvId
InternalRcvId (PrevExternalSndId -> InternalRcvId)
-> Ok PrevExternalSndId -> Ok InternalRcvId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldParser PrevExternalSndId
forall a. FromField a => FieldParser a
fromField Field
x

instance ToField InternalSndId where toField :: InternalSndId -> SQLData
toField (InternalSndId x :: PrevExternalSndId
x) = PrevExternalSndId -> SQLData
forall a. ToField a => a -> SQLData
toField PrevExternalSndId
x

instance FromField InternalSndId where fromField :: FieldParser InternalSndId
fromField x :: Field
x = PrevExternalSndId -> InternalSndId
InternalSndId (PrevExternalSndId -> InternalSndId)
-> Ok PrevExternalSndId -> Ok InternalSndId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldParser PrevExternalSndId
forall a. FromField a => FieldParser a
fromField Field
x

instance ToField InternalId where toField :: InternalId -> SQLData
toField (InternalId x :: PrevExternalSndId
x) = PrevExternalSndId -> SQLData
forall a. ToField a => a -> SQLData
toField PrevExternalSndId
x

instance FromField InternalId where fromField :: FieldParser InternalId
fromField x :: Field
x = PrevExternalSndId -> InternalId
InternalId (PrevExternalSndId -> InternalId)
-> Ok PrevExternalSndId -> Ok InternalId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldParser PrevExternalSndId
forall a. FromField a => FieldParser a
fromField Field
x

instance ToField RcvMsgStatus where toField :: RcvMsgStatus -> SQLData
toField = FilePath -> SQLData
forall a. ToField a => a -> SQLData
toField (FilePath -> SQLData)
-> (RcvMsgStatus -> FilePath) -> RcvMsgStatus -> SQLData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RcvMsgStatus -> FilePath
forall a. Show a => a -> FilePath
show

instance ToField SndMsgStatus where toField :: SndMsgStatus -> SQLData
toField = FilePath -> SQLData
forall a. ToField a => a -> SQLData
toField (FilePath -> SQLData)
-> (SndMsgStatus -> FilePath) -> SndMsgStatus -> SQLData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SndMsgStatus -> FilePath
forall a. Show a => a -> FilePath
show

instance ToField MsgIntegrity where toField :: MsgIntegrity -> SQLData
toField = ByteString -> SQLData
forall a. ToField a => a -> SQLData
toField (ByteString -> SQLData)
-> (MsgIntegrity -> ByteString) -> MsgIntegrity -> SQLData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgIntegrity -> ByteString
serializeMsgIntegrity

instance FromField MsgIntegrity where fromField :: FieldParser MsgIntegrity
fromField = Parser MsgIntegrity -> FieldParser MsgIntegrity
forall k. Typeable k => Parser k -> FieldParser k
blobFieldParser Parser MsgIntegrity
msgIntegrityP

fromFieldToReadable_ :: forall a. (Read a, E.Typeable a) => Field -> Ok a
fromFieldToReadable_ :: Field -> Ok a
fromFieldToReadable_ = \case
  f :: Field
f@(Field (SQLText t :: Text
t) _) ->
    let str :: FilePath
str = Text -> FilePath
T.unpack Text
t
     in case FilePath -> Maybe a
forall a. Read a => FilePath -> Maybe a
readMaybe FilePath
str of
          Just x :: a
x -> a -> Ok a
forall a. a -> Ok a
Ok a
x
          _ -> (FilePath -> FilePath -> FilePath -> ResultError)
-> Field -> FilePath -> Ok a
forall a err.
(Typeable a, Exception err) =>
(FilePath -> FilePath -> FilePath -> err)
-> Field -> FilePath -> Ok a
returnError FilePath -> FilePath -> FilePath -> ResultError
ConversionFailed Field
f ("invalid string: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
str)
  f :: Field
f -> (FilePath -> FilePath -> FilePath -> ResultError)
-> Field -> FilePath -> Ok a
forall a err.
(Typeable a, Exception err) =>
(FilePath -> FilePath -> FilePath -> err)
-> Field -> FilePath -> Ok a
returnError FilePath -> FilePath -> FilePath -> ResultError
ConversionFailed Field
f "expecting SQLText column type"

{- ORMOLU_DISABLE -}
-- SQLite.Simple only has these up to 10 fields, which is insufficient for some of our queries
instance (FromField a, FromField b, FromField c, FromField d, FromField e,
          FromField f, FromField g, FromField h, FromField i, FromField j,
          FromField k) =>
  FromRow (a,b,c,d,e,f,g,h,i,j,k) where
  fromRow :: RowParser (a, b, c, d, e, f, g, h, i, j, k)
fromRow = (,,,,,,,,,,) (a
 -> b
 -> c
 -> d
 -> e
 -> f
 -> g
 -> h
 -> i
 -> j
 -> k
 -> (a, b, c, d, e, f, g, h, i, j, k))
-> RowParser a
-> RowParser
     (b
      -> c
      -> d
      -> e
      -> f
      -> g
      -> h
      -> i
      -> j
      -> k
      -> (a, b, c, d, e, f, g, h, i, j, k))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RowParser a
forall a. FromField a => RowParser a
field RowParser
  (b
   -> c
   -> d
   -> e
   -> f
   -> g
   -> h
   -> i
   -> j
   -> k
   -> (a, b, c, d, e, f, g, h, i, j, k))
-> RowParser b
-> RowParser
     (c
      -> d
      -> e
      -> f
      -> g
      -> h
      -> i
      -> j
      -> k
      -> (a, b, c, d, e, f, g, h, i, j, k))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RowParser b
forall a. FromField a => RowParser a
field RowParser
  (c
   -> d
   -> e
   -> f
   -> g
   -> h
   -> i
   -> j
   -> k
   -> (a, b, c, d, e, f, g, h, i, j, k))
-> RowParser c
-> RowParser
     (d
      -> e
      -> f
      -> g
      -> h
      -> i
      -> j
      -> k
      -> (a, b, c, d, e, f, g, h, i, j, k))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RowParser c
forall a. FromField a => RowParser a
field RowParser
  (d
   -> e
   -> f
   -> g
   -> h
   -> i
   -> j
   -> k
   -> (a, b, c, d, e, f, g, h, i, j, k))
-> RowParser d
-> RowParser
     (e
      -> f -> g -> h -> i -> j -> k -> (a, b, c, d, e, f, g, h, i, j, k))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RowParser d
forall a. FromField a => RowParser a
field RowParser
  (e
   -> f -> g -> h -> i -> j -> k -> (a, b, c, d, e, f, g, h, i, j, k))
-> RowParser e
-> RowParser
     (f -> g -> h -> i -> j -> k -> (a, b, c, d, e, f, g, h, i, j, k))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RowParser e
forall a. FromField a => RowParser a
field
                         RowParser
  (f -> g -> h -> i -> j -> k -> (a, b, c, d, e, f, g, h, i, j, k))
-> RowParser f
-> RowParser
     (g -> h -> i -> j -> k -> (a, b, c, d, e, f, g, h, i, j, k))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RowParser f
forall a. FromField a => RowParser a
field RowParser
  (g -> h -> i -> j -> k -> (a, b, c, d, e, f, g, h, i, j, k))
-> RowParser g
-> RowParser
     (h -> i -> j -> k -> (a, b, c, d, e, f, g, h, i, j, k))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RowParser g
forall a. FromField a => RowParser a
field RowParser (h -> i -> j -> k -> (a, b, c, d, e, f, g, h, i, j, k))
-> RowParser h
-> RowParser (i -> j -> k -> (a, b, c, d, e, f, g, h, i, j, k))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RowParser h
forall a. FromField a => RowParser a
field RowParser (i -> j -> k -> (a, b, c, d, e, f, g, h, i, j, k))
-> RowParser i
-> RowParser (j -> k -> (a, b, c, d, e, f, g, h, i, j, k))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RowParser i
forall a. FromField a => RowParser a
field RowParser (j -> k -> (a, b, c, d, e, f, g, h, i, j, k))
-> RowParser j
-> RowParser (k -> (a, b, c, d, e, f, g, h, i, j, k))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RowParser j
forall a. FromField a => RowParser a
field
                         RowParser (k -> (a, b, c, d, e, f, g, h, i, j, k))
-> RowParser k -> RowParser (a, b, c, d, e, f, g, h, i, j, k)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RowParser k
forall a. FromField a => RowParser a
field
{- ORMOLU_ENABLE -}

-- * Server upsert helper

upsertServer_ :: DB.Connection -> SMPServer -> IO ()
upsertServer_ :: Connection -> SMPServer -> IO ()
upsertServer_ dbConn :: Connection
dbConn SMPServer {FilePath
host :: FilePath
host :: SMPServer -> FilePath
host, Maybe FilePath
port :: Maybe FilePath
port :: SMPServer -> Maybe FilePath
port, Maybe KeyHash
keyHash :: SMPServer -> Maybe KeyHash
keyHash :: Maybe KeyHash
keyHash} = do
  let port_ :: FilePath
port_ = Maybe FilePath -> FilePath
serializePort_ Maybe FilePath
port
  Connection -> Query -> [NamedParam] -> IO ()
DB.executeNamed
    Connection
dbConn
    [sql|
      INSERT INTO servers (host, port, key_hash) VALUES (:host,:port,:key_hash)
      ON CONFLICT (host, port) DO UPDATE SET
        host=excluded.host,
        port=excluded.port,
        key_hash=excluded.key_hash;
    |]
    [":host" Text -> FilePath -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= FilePath
host, ":port" Text -> FilePath -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= FilePath
port_, ":key_hash" Text -> Maybe KeyHash -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= Maybe KeyHash
keyHash]

-- * createRcvConn helpers

insertRcvQueue_ :: DB.Connection -> RcvQueue -> IO ()
insertRcvQueue_ :: Connection -> RcvQueue -> IO ()
insertRcvQueue_ dbConn :: Connection
dbConn RcvQueue {..} = do
  let port_ :: FilePath
port_ = Maybe FilePath -> FilePath
serializePort_ (Maybe FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ SMPServer -> Maybe FilePath
port SMPServer
server
  Connection -> Query -> [NamedParam] -> IO ()
DB.executeNamed
    Connection
dbConn
    [sql|
      INSERT INTO rcv_queues
        ( host, port, rcv_id, conn_alias, rcv_private_key, snd_id, snd_key, decrypt_key, verify_key, status)
      VALUES
        (:host,:port,:rcv_id,:conn_alias,:rcv_private_key,:snd_id,:snd_key,:decrypt_key,:verify_key,:status);
    |]
    [ ":host" Text -> FilePath -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= SMPServer -> FilePath
host SMPServer
server,
      ":port" Text -> FilePath -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= FilePath
port_,
      ":rcv_id" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString
rcvId,
      ":conn_alias" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString
connAlias,
      ":rcv_private_key" Text -> DecryptionKey -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= DecryptionKey
rcvPrivateKey,
      ":snd_id" Text -> Maybe ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= Maybe ByteString
sndId,
      ":snd_key" Text -> Maybe VerificationKey -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= Maybe VerificationKey
sndKey,
      ":decrypt_key" Text -> DecryptionKey -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= DecryptionKey
decryptKey,
      ":verify_key" Text -> Maybe VerificationKey -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= Maybe VerificationKey
verifyKey,
      ":status" Text -> QueueStatus -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= QueueStatus
status
    ]

insertRcvConnection_ :: DB.Connection -> RcvQueue -> IO ()
insertRcvConnection_ :: Connection -> RcvQueue -> IO ()
insertRcvConnection_ dbConn :: Connection
dbConn RcvQueue {SMPServer
server :: SMPServer
$sel:server:RcvQueue :: RcvQueue -> SMPServer
server, ByteString
rcvId :: ByteString
$sel:rcvId:RcvQueue :: RcvQueue -> ByteString
rcvId, ByteString
connAlias :: ByteString
$sel:connAlias:RcvQueue :: RcvQueue -> ByteString
connAlias} = do
  let port_ :: FilePath
port_ = Maybe FilePath -> FilePath
serializePort_ (Maybe FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ SMPServer -> Maybe FilePath
port SMPServer
server
  Connection -> Query -> [NamedParam] -> IO ()
DB.executeNamed
    Connection
dbConn
    [sql|
      INSERT INTO connections
        ( conn_alias, rcv_host, rcv_port, rcv_id, snd_host, snd_port, snd_id,
          last_internal_msg_id, last_internal_rcv_msg_id, last_internal_snd_msg_id,
          last_external_snd_msg_id, last_rcv_msg_hash, last_snd_msg_hash)
      VALUES
        (:conn_alias,:rcv_host,:rcv_port,:rcv_id,     NULL,     NULL,   NULL,
          0, 0, 0, 0, x'', x'');
    |]
    [":conn_alias" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString
connAlias, ":rcv_host" Text -> FilePath -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= SMPServer -> FilePath
host SMPServer
server, ":rcv_port" Text -> FilePath -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= FilePath
port_, ":rcv_id" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString
rcvId]

-- * createSndConn helpers

insertSndQueue_ :: DB.Connection -> SndQueue -> IO ()
insertSndQueue_ :: Connection -> SndQueue -> IO ()
insertSndQueue_ dbConn :: Connection
dbConn SndQueue {..} = do
  let port_ :: FilePath
port_ = Maybe FilePath -> FilePath
serializePort_ (Maybe FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ SMPServer -> Maybe FilePath
port SMPServer
server
  Connection -> Query -> [NamedParam] -> IO ()
DB.executeNamed
    Connection
dbConn
    [sql|
      INSERT INTO snd_queues
        ( host, port, snd_id, conn_alias, snd_private_key, encrypt_key, sign_key, status)
      VALUES
        (:host,:port,:snd_id,:conn_alias,:snd_private_key,:encrypt_key,:sign_key,:status);
    |]
    [ ":host" Text -> FilePath -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= SMPServer -> FilePath
host SMPServer
server,
      ":port" Text -> FilePath -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= FilePath
port_,
      ":snd_id" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString
sndId,
      ":conn_alias" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString
connAlias,
      ":snd_private_key" Text -> DecryptionKey -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= DecryptionKey
sndPrivateKey,
      ":encrypt_key" Text -> VerificationKey -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= VerificationKey
encryptKey,
      ":sign_key" Text -> DecryptionKey -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= DecryptionKey
signKey,
      ":status" Text -> QueueStatus -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= QueueStatus
status
    ]

insertSndConnection_ :: DB.Connection -> SndQueue -> IO ()
insertSndConnection_ :: Connection -> SndQueue -> IO ()
insertSndConnection_ dbConn :: Connection
dbConn SndQueue {SMPServer
server :: SMPServer
$sel:server:SndQueue :: SndQueue -> SMPServer
server, ByteString
sndId :: ByteString
$sel:sndId:SndQueue :: SndQueue -> ByteString
sndId, ByteString
connAlias :: ByteString
$sel:connAlias:SndQueue :: SndQueue -> ByteString
connAlias} = do
  let port_ :: FilePath
port_ = Maybe FilePath -> FilePath
serializePort_ (Maybe FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ SMPServer -> Maybe FilePath
port SMPServer
server
  Connection -> Query -> [NamedParam] -> IO ()
DB.executeNamed
    Connection
dbConn
    [sql|
      INSERT INTO connections
        ( conn_alias, rcv_host, rcv_port, rcv_id, snd_host, snd_port, snd_id,
          last_internal_msg_id, last_internal_rcv_msg_id, last_internal_snd_msg_id,
          last_external_snd_msg_id, last_rcv_msg_hash, last_snd_msg_hash)
      VALUES
        (:conn_alias,     NULL,     NULL,   NULL,:snd_host,:snd_port,:snd_id,
          0, 0, 0, 0, x'', x'');
    |]
    [":conn_alias" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString
connAlias, ":snd_host" Text -> FilePath -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= SMPServer -> FilePath
host SMPServer
server, ":snd_port" Text -> FilePath -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= FilePath
port_, ":snd_id" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString
sndId]

-- * getConn helpers

getConn_ :: DB.Connection -> ConnAlias -> IO (Either StoreError SomeConn)
getConn_ :: Connection -> ByteString -> IO (Either StoreError SomeConn)
getConn_ dbConn :: Connection
dbConn connAlias :: ByteString
connAlias = do
  Maybe RcvQueue
rQ <- Connection -> ByteString -> IO (Maybe RcvQueue)
retrieveRcvQueueByConnAlias_ Connection
dbConn ByteString
connAlias
  Maybe SndQueue
sQ <- Connection -> ByteString -> IO (Maybe SndQueue)
retrieveSndQueueByConnAlias_ Connection
dbConn ByteString
connAlias
  Either StoreError SomeConn -> IO (Either StoreError SomeConn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StoreError SomeConn -> IO (Either StoreError SomeConn))
-> Either StoreError SomeConn -> IO (Either StoreError SomeConn)
forall a b. (a -> b) -> a -> b
$ case (Maybe RcvQueue
rQ, Maybe SndQueue
sQ) of
    (Just rcvQ :: RcvQueue
rcvQ, Just sndQ :: SndQueue
sndQ) -> SomeConn -> Either StoreError SomeConn
forall a b. b -> Either a b
Right (SomeConn -> Either StoreError SomeConn)
-> SomeConn -> Either StoreError SomeConn
forall a b. (a -> b) -> a -> b
$ SConnType 'CDuplex -> Connection 'CDuplex -> SomeConn
forall (d :: ConnType). SConnType d -> Connection d -> SomeConn
SomeConn SConnType 'CDuplex
SCDuplex (ByteString -> RcvQueue -> SndQueue -> Connection 'CDuplex
DuplexConnection ByteString
connAlias RcvQueue
rcvQ SndQueue
sndQ)
    (Just rcvQ :: RcvQueue
rcvQ, Nothing) -> SomeConn -> Either StoreError SomeConn
forall a b. b -> Either a b
Right (SomeConn -> Either StoreError SomeConn)
-> SomeConn -> Either StoreError SomeConn
forall a b. (a -> b) -> a -> b
$ SConnType 'CRcv -> Connection 'CRcv -> SomeConn
forall (d :: ConnType). SConnType d -> Connection d -> SomeConn
SomeConn SConnType 'CRcv
SCRcv (ByteString -> RcvQueue -> Connection 'CRcv
RcvConnection ByteString
connAlias RcvQueue
rcvQ)
    (Nothing, Just sndQ :: SndQueue
sndQ) -> SomeConn -> Either StoreError SomeConn
forall a b. b -> Either a b
Right (SomeConn -> Either StoreError SomeConn)
-> SomeConn -> Either StoreError SomeConn
forall a b. (a -> b) -> a -> b
$ SConnType 'CSnd -> Connection 'CSnd -> SomeConn
forall (d :: ConnType). SConnType d -> Connection d -> SomeConn
SomeConn SConnType 'CSnd
SCSnd (ByteString -> SndQueue -> Connection 'CSnd
SndConnection ByteString
connAlias SndQueue
sndQ)
    _ -> StoreError -> Either StoreError SomeConn
forall a b. a -> Either a b
Left StoreError
SEConnNotFound

retrieveRcvQueueByConnAlias_ :: DB.Connection -> ConnAlias -> IO (Maybe RcvQueue)
retrieveRcvQueueByConnAlias_ :: Connection -> ByteString -> IO (Maybe RcvQueue)
retrieveRcvQueueByConnAlias_ dbConn :: Connection
dbConn connAlias :: ByteString
connAlias = do
  [(Maybe KeyHash, FilePath, FilePath, ByteString, ByteString,
  DecryptionKey, Maybe ByteString, Maybe VerificationKey,
  DecryptionKey, Maybe VerificationKey, QueueStatus)]
r <-
    Connection
-> Query
-> [NamedParam]
-> IO
     [(Maybe KeyHash, FilePath, FilePath, ByteString, ByteString,
       DecryptionKey, Maybe ByteString, Maybe VerificationKey,
       DecryptionKey, Maybe VerificationKey, QueueStatus)]
forall r.
FromRow r =>
Connection -> Query -> [NamedParam] -> IO [r]
DB.queryNamed
      Connection
dbConn
      [sql|
        SELECT
          s.key_hash, q.host, q.port, q.rcv_id, q.conn_alias, q.rcv_private_key,
          q.snd_id, q.snd_key, q.decrypt_key, q.verify_key, q.status
        FROM rcv_queues q
        INNER JOIN servers s ON q.host = s.host AND q.port = s.port
        WHERE q.conn_alias = :conn_alias;
      |]
      [":conn_alias" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString
connAlias]
  case [(Maybe KeyHash, FilePath, FilePath, ByteString, ByteString,
  DecryptionKey, Maybe ByteString, Maybe VerificationKey,
  DecryptionKey, Maybe VerificationKey, QueueStatus)]
r of
    [(keyHash :: Maybe KeyHash
keyHash, host :: FilePath
host, port :: FilePath
port, rcvId :: ByteString
rcvId, cAlias :: ByteString
cAlias, rcvPrivateKey :: DecryptionKey
rcvPrivateKey, sndId :: Maybe ByteString
sndId, sndKey :: Maybe VerificationKey
sndKey, decryptKey :: DecryptionKey
decryptKey, verifyKey :: Maybe VerificationKey
verifyKey, status :: QueueStatus
status)] -> do
      let srv :: SMPServer
srv = FilePath -> Maybe FilePath -> Maybe KeyHash -> SMPServer
SMPServer FilePath
host (FilePath -> Maybe FilePath
deserializePort_ FilePath
port) Maybe KeyHash
keyHash
      Maybe RcvQueue -> IO (Maybe RcvQueue)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe RcvQueue -> IO (Maybe RcvQueue))
-> (RcvQueue -> Maybe RcvQueue) -> RcvQueue -> IO (Maybe RcvQueue)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RcvQueue -> Maybe RcvQueue
forall a. a -> Maybe a
Just (RcvQueue -> IO (Maybe RcvQueue))
-> RcvQueue -> IO (Maybe RcvQueue)
forall a b. (a -> b) -> a -> b
$ SMPServer
-> ByteString
-> ByteString
-> DecryptionKey
-> Maybe ByteString
-> Maybe VerificationKey
-> DecryptionKey
-> Maybe VerificationKey
-> QueueStatus
-> RcvQueue
RcvQueue SMPServer
srv ByteString
rcvId ByteString
cAlias DecryptionKey
rcvPrivateKey Maybe ByteString
sndId Maybe VerificationKey
sndKey DecryptionKey
decryptKey Maybe VerificationKey
verifyKey QueueStatus
status
    _ -> Maybe RcvQueue -> IO (Maybe RcvQueue)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe RcvQueue
forall a. Maybe a
Nothing

retrieveSndQueueByConnAlias_ :: DB.Connection -> ConnAlias -> IO (Maybe SndQueue)
retrieveSndQueueByConnAlias_ :: Connection -> ByteString -> IO (Maybe SndQueue)
retrieveSndQueueByConnAlias_ dbConn :: Connection
dbConn connAlias :: ByteString
connAlias = do
  [(Maybe KeyHash, FilePath, FilePath, ByteString, ByteString,
  DecryptionKey, VerificationKey, DecryptionKey, QueueStatus)]
r <-
    Connection
-> Query
-> [NamedParam]
-> IO
     [(Maybe KeyHash, FilePath, FilePath, ByteString, ByteString,
       DecryptionKey, VerificationKey, DecryptionKey, QueueStatus)]
forall r.
FromRow r =>
Connection -> Query -> [NamedParam] -> IO [r]
DB.queryNamed
      Connection
dbConn
      [sql|
        SELECT
          s.key_hash, q.host, q.port, q.snd_id, q.conn_alias,
          q.snd_private_key, q.encrypt_key, q.sign_key, q.status
        FROM snd_queues q
        INNER JOIN servers s ON q.host = s.host AND q.port = s.port
        WHERE q.conn_alias = :conn_alias;
      |]
      [":conn_alias" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString
connAlias]
  case [(Maybe KeyHash, FilePath, FilePath, ByteString, ByteString,
  DecryptionKey, VerificationKey, DecryptionKey, QueueStatus)]
r of
    [(keyHash :: Maybe KeyHash
keyHash, host :: FilePath
host, port :: FilePath
port, sndId :: ByteString
sndId, cAlias :: ByteString
cAlias, sndPrivateKey :: DecryptionKey
sndPrivateKey, encryptKey :: VerificationKey
encryptKey, signKey :: DecryptionKey
signKey, status :: QueueStatus
status)] -> do
      let srv :: SMPServer
srv = FilePath -> Maybe FilePath -> Maybe KeyHash -> SMPServer
SMPServer FilePath
host (FilePath -> Maybe FilePath
deserializePort_ FilePath
port) Maybe KeyHash
keyHash
      Maybe SndQueue -> IO (Maybe SndQueue)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SndQueue -> IO (Maybe SndQueue))
-> (SndQueue -> Maybe SndQueue) -> SndQueue -> IO (Maybe SndQueue)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SndQueue -> Maybe SndQueue
forall a. a -> Maybe a
Just (SndQueue -> IO (Maybe SndQueue))
-> SndQueue -> IO (Maybe SndQueue)
forall a b. (a -> b) -> a -> b
$ SMPServer
-> ByteString
-> ByteString
-> DecryptionKey
-> VerificationKey
-> DecryptionKey
-> QueueStatus
-> SndQueue
SndQueue SMPServer
srv ByteString
sndId ByteString
cAlias DecryptionKey
sndPrivateKey VerificationKey
encryptKey DecryptionKey
signKey QueueStatus
status
    _ -> Maybe SndQueue -> IO (Maybe SndQueue)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SndQueue
forall a. Maybe a
Nothing

-- * upgradeRcvConnToDuplex helpers

updateConnWithSndQueue_ :: DB.Connection -> ConnAlias -> SndQueue -> IO ()
updateConnWithSndQueue_ :: Connection -> ByteString -> SndQueue -> IO ()
updateConnWithSndQueue_ dbConn :: Connection
dbConn connAlias :: ByteString
connAlias SndQueue {SMPServer
server :: SMPServer
$sel:server:SndQueue :: SndQueue -> SMPServer
server, ByteString
sndId :: ByteString
$sel:sndId:SndQueue :: SndQueue -> ByteString
sndId} = do
  let port_ :: FilePath
port_ = Maybe FilePath -> FilePath
serializePort_ (Maybe FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ SMPServer -> Maybe FilePath
port SMPServer
server
  Connection -> Query -> [NamedParam] -> IO ()
DB.executeNamed
    Connection
dbConn
    [sql|
      UPDATE connections
      SET snd_host = :snd_host, snd_port = :snd_port, snd_id = :snd_id
      WHERE conn_alias = :conn_alias;
    |]
    [":snd_host" Text -> FilePath -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= SMPServer -> FilePath
host SMPServer
server, ":snd_port" Text -> FilePath -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= FilePath
port_, ":snd_id" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString
sndId, ":conn_alias" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString
connAlias]

-- * upgradeSndConnToDuplex helpers

updateConnWithRcvQueue_ :: DB.Connection -> ConnAlias -> RcvQueue -> IO ()
updateConnWithRcvQueue_ :: Connection -> ByteString -> RcvQueue -> IO ()
updateConnWithRcvQueue_ dbConn :: Connection
dbConn connAlias :: ByteString
connAlias RcvQueue {SMPServer
server :: SMPServer
$sel:server:RcvQueue :: RcvQueue -> SMPServer
server, ByteString
rcvId :: ByteString
$sel:rcvId:RcvQueue :: RcvQueue -> ByteString
rcvId} = do
  let port_ :: FilePath
port_ = Maybe FilePath -> FilePath
serializePort_ (Maybe FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ SMPServer -> Maybe FilePath
port SMPServer
server
  Connection -> Query -> [NamedParam] -> IO ()
DB.executeNamed
    Connection
dbConn
    [sql|
      UPDATE connections
      SET rcv_host = :rcv_host, rcv_port = :rcv_port, rcv_id = :rcv_id
      WHERE conn_alias = :conn_alias;
    |]
    [":rcv_host" Text -> FilePath -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= SMPServer -> FilePath
host SMPServer
server, ":rcv_port" Text -> FilePath -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= FilePath
port_, ":rcv_id" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString
rcvId, ":conn_alias" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString
connAlias]

-- * updateRcvIds helpers

retrieveLastIdsAndHashRcv_ :: DB.Connection -> ConnAlias -> IO (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash)
retrieveLastIdsAndHashRcv_ :: Connection
-> ByteString
-> IO (InternalId, InternalRcvId, PrevExternalSndId, ByteString)
retrieveLastIdsAndHashRcv_ dbConn :: Connection
dbConn connAlias :: ByteString
connAlias = do
  [(lastInternalId :: InternalId
lastInternalId, lastInternalRcvId :: InternalRcvId
lastInternalRcvId, lastExternalSndId :: PrevExternalSndId
lastExternalSndId, lastRcvHash :: ByteString
lastRcvHash)] <-
    Connection
-> Query
-> [NamedParam]
-> IO [(InternalId, InternalRcvId, PrevExternalSndId, ByteString)]
forall r.
FromRow r =>
Connection -> Query -> [NamedParam] -> IO [r]
DB.queryNamed
      Connection
dbConn
      [sql|
        SELECT last_internal_msg_id, last_internal_rcv_msg_id, last_external_snd_msg_id, last_rcv_msg_hash
        FROM connections
        WHERE conn_alias = :conn_alias;
      |]
      [":conn_alias" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString
connAlias]
  (InternalId, InternalRcvId, PrevExternalSndId, ByteString)
-> IO (InternalId, InternalRcvId, PrevExternalSndId, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (InternalId
lastInternalId, InternalRcvId
lastInternalRcvId, PrevExternalSndId
lastExternalSndId, ByteString
lastRcvHash)

updateLastIdsRcv_ :: DB.Connection -> ConnAlias -> InternalId -> InternalRcvId -> IO ()
updateLastIdsRcv_ :: Connection -> ByteString -> InternalId -> InternalRcvId -> IO ()
updateLastIdsRcv_ dbConn :: Connection
dbConn connAlias :: ByteString
connAlias newInternalId :: InternalId
newInternalId newInternalRcvId :: InternalRcvId
newInternalRcvId =
  Connection -> Query -> [NamedParam] -> IO ()
DB.executeNamed
    Connection
dbConn
    [sql|
      UPDATE connections
      SET last_internal_msg_id = :last_internal_msg_id,
          last_internal_rcv_msg_id = :last_internal_rcv_msg_id
      WHERE conn_alias = :conn_alias;
    |]
    [ ":last_internal_msg_id" Text -> InternalId -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= InternalId
newInternalId,
      ":last_internal_rcv_msg_id" Text -> InternalRcvId -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= InternalRcvId
newInternalRcvId,
      ":conn_alias" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString
connAlias
    ]

-- * createRcvMsg helpers

insertRcvMsgBase_ :: DB.Connection -> ConnAlias -> RcvMsgData -> IO ()
insertRcvMsgBase_ :: Connection -> ByteString -> RcvMsgData -> IO ()
insertRcvMsgBase_ dbConn :: Connection
dbConn connAlias :: ByteString
connAlias RcvMsgData {..} = do
  Connection -> Query -> [NamedParam] -> IO ()
DB.executeNamed
    Connection
dbConn
    [sql|
      INSERT INTO messages
        ( conn_alias, internal_id, internal_ts, internal_rcv_id, internal_snd_id, body)
      VALUES
        (:conn_alias,:internal_id,:internal_ts,:internal_rcv_id,            NULL,:body);
    |]
    [ ":conn_alias" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString
connAlias,
      ":internal_id" Text -> InternalId -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= InternalId
internalId,
      ":internal_ts" Text -> ExternalSndTs -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ExternalSndTs
internalTs,
      ":internal_rcv_id" Text -> InternalRcvId -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= InternalRcvId
internalRcvId,
      ":body" Text -> Text -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString -> Text
decodeUtf8 ByteString
msgBody
    ]

insertRcvMsgDetails_ :: DB.Connection -> ConnAlias -> RcvMsgData -> IO ()
insertRcvMsgDetails_ :: Connection -> ByteString -> RcvMsgData -> IO ()
insertRcvMsgDetails_ dbConn :: Connection
dbConn connAlias :: ByteString
connAlias RcvMsgData {..} =
  Connection -> Query -> [NamedParam] -> IO ()
DB.executeNamed
    Connection
dbConn
    [sql|
      INSERT INTO rcv_messages
        ( conn_alias, internal_rcv_id, internal_id, external_snd_id, external_snd_ts,
          broker_id, broker_ts, rcv_status, ack_brocker_ts, ack_sender_ts,
          internal_hash, external_prev_snd_hash, integrity)
      VALUES
        (:conn_alias,:internal_rcv_id,:internal_id,:external_snd_id,:external_snd_ts,
         :broker_id,:broker_ts,:rcv_status,           NULL,          NULL,
         :internal_hash,:external_prev_snd_hash,:integrity);
    |]
    [ ":conn_alias" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString
connAlias,
      ":internal_rcv_id" Text -> InternalRcvId -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= InternalRcvId
internalRcvId,
      ":internal_id" Text -> InternalId -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= InternalId
internalId,
      ":external_snd_id" Text -> PrevExternalSndId -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= (PrevExternalSndId, ExternalSndTs) -> PrevExternalSndId
forall a b. (a, b) -> a
fst (PrevExternalSndId, ExternalSndTs)
senderMeta,
      ":external_snd_ts" Text -> ExternalSndTs -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= (PrevExternalSndId, ExternalSndTs) -> ExternalSndTs
forall a b. (a, b) -> b
snd (PrevExternalSndId, ExternalSndTs)
senderMeta,
      ":broker_id" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= (ByteString, ExternalSndTs) -> ByteString
forall a b. (a, b) -> a
fst (ByteString, ExternalSndTs)
brokerMeta,
      ":broker_ts" Text -> ExternalSndTs -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= (ByteString, ExternalSndTs) -> ExternalSndTs
forall a b. (a, b) -> b
snd (ByteString, ExternalSndTs)
brokerMeta,
      ":rcv_status" Text -> RcvMsgStatus -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= RcvMsgStatus
Received,
      ":internal_hash" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString
internalHash,
      ":external_prev_snd_hash" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString
externalPrevSndHash,
      ":integrity" Text -> MsgIntegrity -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= MsgIntegrity
msgIntegrity
    ]

updateHashRcv_ :: DB.Connection -> ConnAlias -> RcvMsgData -> IO ()
updateHashRcv_ :: Connection -> ByteString -> RcvMsgData -> IO ()
updateHashRcv_ dbConn :: Connection
dbConn connAlias :: ByteString
connAlias RcvMsgData {..} =
  Connection -> Query -> [NamedParam] -> IO ()
DB.executeNamed
    Connection
dbConn
    -- last_internal_rcv_msg_id equality check prevents race condition in case next id was reserved
    [sql|
      UPDATE connections
      SET last_external_snd_msg_id = :last_external_snd_msg_id,
          last_rcv_msg_hash = :last_rcv_msg_hash
      WHERE conn_alias = :conn_alias
        AND last_internal_rcv_msg_id = :last_internal_rcv_msg_id;
    |]
    [ ":last_external_snd_msg_id" Text -> PrevExternalSndId -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= (PrevExternalSndId, ExternalSndTs) -> PrevExternalSndId
forall a b. (a, b) -> a
fst (PrevExternalSndId, ExternalSndTs)
senderMeta,
      ":last_rcv_msg_hash" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString
internalHash,
      ":conn_alias" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString
connAlias,
      ":last_internal_rcv_msg_id" Text -> InternalRcvId -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= InternalRcvId
internalRcvId
    ]

-- * updateSndIds helpers

retrieveLastIdsAndHashSnd_ :: DB.Connection -> ConnAlias -> IO (InternalId, InternalSndId, PrevSndMsgHash)
retrieveLastIdsAndHashSnd_ :: Connection
-> ByteString -> IO (InternalId, InternalSndId, ByteString)
retrieveLastIdsAndHashSnd_ dbConn :: Connection
dbConn connAlias :: ByteString
connAlias = do
  [(lastInternalId :: InternalId
lastInternalId, lastInternalSndId :: InternalSndId
lastInternalSndId, lastSndHash :: ByteString
lastSndHash)] <-
    Connection
-> Query
-> [NamedParam]
-> IO [(InternalId, InternalSndId, ByteString)]
forall r.
FromRow r =>
Connection -> Query -> [NamedParam] -> IO [r]
DB.queryNamed
      Connection
dbConn
      [sql|
        SELECT last_internal_msg_id, last_internal_snd_msg_id, last_snd_msg_hash
        FROM connections
        WHERE conn_alias = :conn_alias;
      |]
      [":conn_alias" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString
connAlias]
  (InternalId, InternalSndId, ByteString)
-> IO (InternalId, InternalSndId, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (InternalId
lastInternalId, InternalSndId
lastInternalSndId, ByteString
lastSndHash)

updateLastIdsSnd_ :: DB.Connection -> ConnAlias -> InternalId -> InternalSndId -> IO ()
updateLastIdsSnd_ :: Connection -> ByteString -> InternalId -> InternalSndId -> IO ()
updateLastIdsSnd_ dbConn :: Connection
dbConn connAlias :: ByteString
connAlias newInternalId :: InternalId
newInternalId newInternalSndId :: InternalSndId
newInternalSndId =
  Connection -> Query -> [NamedParam] -> IO ()
DB.executeNamed
    Connection
dbConn
    [sql|
      UPDATE connections
      SET last_internal_msg_id = :last_internal_msg_id,
          last_internal_snd_msg_id = :last_internal_snd_msg_id
      WHERE conn_alias = :conn_alias;
    |]
    [ ":last_internal_msg_id" Text -> InternalId -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= InternalId
newInternalId,
      ":last_internal_snd_msg_id" Text -> InternalSndId -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= InternalSndId
newInternalSndId,
      ":conn_alias" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString
connAlias
    ]

-- * createSndMsg helpers

insertSndMsgBase_ :: DB.Connection -> ConnAlias -> SndMsgData -> IO ()
insertSndMsgBase_ :: Connection -> ByteString -> SndMsgData -> IO ()
insertSndMsgBase_ dbConn :: Connection
dbConn connAlias :: ByteString
connAlias SndMsgData {..} = do
  Connection -> Query -> [NamedParam] -> IO ()
DB.executeNamed
    Connection
dbConn
    [sql|
      INSERT INTO messages
        ( conn_alias, internal_id, internal_ts, internal_rcv_id, internal_snd_id, body)
      VALUES
        (:conn_alias,:internal_id,:internal_ts,            NULL,:internal_snd_id,:body);
    |]
    [ ":conn_alias" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString
connAlias,
      ":internal_id" Text -> InternalId -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= InternalId
internalId,
      ":internal_ts" Text -> ExternalSndTs -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ExternalSndTs
internalTs,
      ":internal_snd_id" Text -> InternalSndId -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= InternalSndId
internalSndId,
      ":body" Text -> Text -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString -> Text
decodeUtf8 ByteString
msgBody
    ]

insertSndMsgDetails_ :: DB.Connection -> ConnAlias -> SndMsgData -> IO ()
insertSndMsgDetails_ :: Connection -> ByteString -> SndMsgData -> IO ()
insertSndMsgDetails_ dbConn :: Connection
dbConn connAlias :: ByteString
connAlias SndMsgData {..} =
  Connection -> Query -> [NamedParam] -> IO ()
DB.executeNamed
    Connection
dbConn
    [sql|
      INSERT INTO snd_messages
        ( conn_alias, internal_snd_id, internal_id, snd_status, sent_ts, delivered_ts, internal_hash)
      VALUES
        (:conn_alias,:internal_snd_id,:internal_id,:snd_status,    NULL,         NULL,:internal_hash);
    |]
    [ ":conn_alias" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString
connAlias,
      ":internal_snd_id" Text -> InternalSndId -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= InternalSndId
internalSndId,
      ":internal_id" Text -> InternalId -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= InternalId
internalId,
      ":snd_status" Text -> SndMsgStatus -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= SndMsgStatus
Created,
      ":internal_hash" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString
internalHash
    ]

updateHashSnd_ :: DB.Connection -> ConnAlias -> SndMsgData -> IO ()
updateHashSnd_ :: Connection -> ByteString -> SndMsgData -> IO ()
updateHashSnd_ dbConn :: Connection
dbConn connAlias :: ByteString
connAlias SndMsgData {..} =
  Connection -> Query -> [NamedParam] -> IO ()
DB.executeNamed
    Connection
dbConn
    -- last_internal_snd_msg_id equality check prevents race condition in case next id was reserved
    [sql|
      UPDATE connections
      SET last_snd_msg_hash = :last_snd_msg_hash
      WHERE conn_alias = :conn_alias
        AND last_internal_snd_msg_id = :last_internal_snd_msg_id;
    |]
    [ ":last_snd_msg_hash" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString
internalHash,
      ":conn_alias" Text -> ByteString -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= ByteString
connAlias,
      ":last_internal_snd_msg_id" Text -> InternalSndId -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= InternalSndId
internalSndId
    ]