{-# LANGUAGE CPP #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}

module Simplex.Chat.Store.Remote where

import Control.Monad.Except
import Data.Int (Int64)
import Data.Text (Text)
import Data.Text.Encoding (decodeASCII, encodeUtf8)
import qualified Data.X509 as X
import Data.Word (Word16)
import Simplex.Chat.Remote.Types
import Simplex.Chat.Store.Shared
import Simplex.Messaging.Agent.Store.AgentStore (firstRow, maybeFirstRow)
import qualified Simplex.Messaging.Agent.Store.DB as DB
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String (StrEncoding (..))
import Simplex.RemoteControl.Types
import UnliftIO
#if defined(dbPostgres)
import Database.PostgreSQL.Simple (Only (..), Query)
import Database.PostgreSQL.Simple.SqlQQ (sql)
#else
import Database.SQLite.Simple (Only (..), Query)
import Database.SQLite.Simple.QQ (sql)
#endif

insertRemoteHost :: DB.Connection -> Text -> FilePath -> Maybe RCCtrlAddress -> Maybe Word16 -> RCHostPairing -> ExceptT StoreError IO RemoteHostId
insertRemoteHost :: Connection
-> Text
-> FilePath
-> Maybe RCCtrlAddress
-> Maybe Word16
-> RCHostPairing
-> ExceptT StoreError IO RemoteCtrlId
insertRemoteHost Connection
db Text
hostDeviceName FilePath
storePath Maybe RCCtrlAddress
rcAddr_ Maybe Word16
bindPort_ RCHostPairing {APrivateSignKey
caKey :: APrivateSignKey
caKey :: RCHostPairing -> APrivateSignKey
caKey, SignedCertificate
caCert :: SignedCertificate
caCert :: RCHostPairing -> SignedCertificate
caCert, PrivateKeyEd25519
idPrivKey :: PrivateKeyEd25519
idPrivKey :: RCHostPairing -> PrivateKeyEd25519
idPrivKey, knownHost :: RCHostPairing -> Maybe KnownHostPairing
knownHost = Maybe KnownHostPairing
kh_} = do
  KnownHostPairing {KeyHash
hostFingerprint :: KeyHash
hostFingerprint :: KnownHostPairing -> KeyHash
hostFingerprint, PublicKeyX25519
hostDhPubKey :: PublicKeyX25519
hostDhPubKey :: KnownHostPairing -> PublicKeyX25519
hostDhPubKey} <-
    ExceptT StoreError IO KnownHostPairing
-> (KnownHostPairing -> ExceptT StoreError IO KnownHostPairing)
-> Maybe KnownHostPairing
-> ExceptT StoreError IO KnownHostPairing
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (StoreError -> ExceptT StoreError IO KnownHostPairing
forall a. StoreError -> ExceptT StoreError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError StoreError
SERemoteHostUnknown) KnownHostPairing -> ExceptT StoreError IO KnownHostPairing
forall a. a -> ExceptT StoreError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe KnownHostPairing
kh_
  StoreError -> ExceptT StoreError IO () -> ExceptT StoreError IO ()
forall a.
StoreError -> ExceptT StoreError IO a -> ExceptT StoreError IO a
checkConstraint StoreError
SERemoteHostDuplicateCA (ExceptT StoreError IO () -> ExceptT StoreError IO ())
-> (IO () -> ExceptT StoreError IO ())
-> IO ()
-> ExceptT StoreError IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> ExceptT StoreError IO ()
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT StoreError IO ())
-> IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$
    Connection
-> Query
-> (Text, FilePath, Maybe Text, Maybe Text, Maybe Word16,
    APrivateSignKey, SignedObject Certificate, PrivateKeyEd25519,
    KeyHash, PublicKeyX25519)
-> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
      Connection
db
      [sql|
        INSERT INTO remote_hosts
          (host_device_name, store_path, bind_addr, bind_iface, bind_port, ca_key, ca_cert, id_key, host_fingerprint, host_dh_pub)
        VALUES
          (?, ?, ?, ?, ?, ?, ?, ?, ?, ?)
      |]
      (Text
hostDeviceName, FilePath
storePath, Maybe Text
bindAddr_, Maybe Text
bindIface_, Maybe Word16
bindPort_, APrivateSignKey
caKey, SignedCertificate -> SignedObject Certificate
forall a. SignedExact a -> SignedObject a
C.SignedObject SignedCertificate
caCert, PrivateKeyEd25519
idPrivKey, KeyHash
hostFingerprint, PublicKeyX25519
hostDhPubKey)
  IO RemoteCtrlId -> ExceptT StoreError IO RemoteCtrlId
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RemoteCtrlId -> ExceptT StoreError IO RemoteCtrlId)
-> IO RemoteCtrlId -> ExceptT StoreError IO RemoteCtrlId
forall a b. (a -> b) -> a -> b
$ Connection -> IO RemoteCtrlId
insertedRowId Connection
db
  where
    (Maybe Text
bindAddr_, Maybe Text
bindIface_) = Maybe RCCtrlAddress -> (Maybe Text, Maybe Text)
rcCtrlAddressFields_ Maybe RCCtrlAddress
rcAddr_

getRemoteHosts :: DB.Connection -> IO [RemoteHost]
getRemoteHosts :: Connection -> IO [RemoteHost]
getRemoteHosts Connection
db =
  ((RemoteCtrlId, Text, FilePath, APrivateSignKey,
  SignedObject Certificate, PrivateKeyEd25519, KeyHash,
  PublicKeyX25519, Maybe Text, Maybe Text, Maybe Word16)
 -> RemoteHost)
-> [(RemoteCtrlId, Text, FilePath, APrivateSignKey,
     SignedObject Certificate, PrivateKeyEd25519, KeyHash,
     PublicKeyX25519, Maybe Text, Maybe Text, Maybe Word16)]
-> [RemoteHost]
forall a b. (a -> b) -> [a] -> [b]
map (RemoteCtrlId, Text, FilePath, APrivateSignKey,
 SignedObject Certificate, PrivateKeyEd25519, KeyHash,
 PublicKeyX25519, Maybe Text, Maybe Text, Maybe Word16)
-> RemoteHost
toRemoteHost ([(RemoteCtrlId, Text, FilePath, APrivateSignKey,
   SignedObject Certificate, PrivateKeyEd25519, KeyHash,
   PublicKeyX25519, Maybe Text, Maybe Text, Maybe Word16)]
 -> [RemoteHost])
-> IO
     [(RemoteCtrlId, Text, FilePath, APrivateSignKey,
       SignedObject Certificate, PrivateKeyEd25519, KeyHash,
       PublicKeyX25519, Maybe Text, Maybe Text, Maybe Word16)]
-> IO [RemoteHost]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection
-> Query
-> IO
     [(RemoteCtrlId, Text, FilePath, APrivateSignKey,
       SignedObject Certificate, PrivateKeyEd25519, KeyHash,
       PublicKeyX25519, Maybe Text, Maybe Text, Maybe Word16)]
forall r. FromRow r => Connection -> Query -> IO [r]
DB.query_ Connection
db Query
remoteHostQuery

getRemoteHost :: DB.Connection -> RemoteHostId -> ExceptT StoreError IO RemoteHost
getRemoteHost :: Connection -> RemoteCtrlId -> ExceptT StoreError IO RemoteHost
getRemoteHost Connection
db RemoteCtrlId
remoteHostId =
  IO (Either StoreError RemoteHost)
-> ExceptT StoreError IO RemoteHost
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either StoreError RemoteHost)
 -> ExceptT StoreError IO RemoteHost)
-> (IO
      [(RemoteCtrlId, Text, FilePath, APrivateSignKey,
        SignedObject Certificate, PrivateKeyEd25519, KeyHash,
        PublicKeyX25519, Maybe Text, Maybe Text, Maybe Word16)]
    -> IO (Either StoreError RemoteHost))
-> IO
     [(RemoteCtrlId, Text, FilePath, APrivateSignKey,
       SignedObject Certificate, PrivateKeyEd25519, KeyHash,
       PublicKeyX25519, Maybe Text, Maybe Text, Maybe Word16)]
-> ExceptT StoreError IO RemoteHost
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((RemoteCtrlId, Text, FilePath, APrivateSignKey,
  SignedObject Certificate, PrivateKeyEd25519, KeyHash,
  PublicKeyX25519, Maybe Text, Maybe Text, Maybe Word16)
 -> RemoteHost)
-> StoreError
-> IO
     [(RemoteCtrlId, Text, FilePath, APrivateSignKey,
       SignedObject Certificate, PrivateKeyEd25519, KeyHash,
       PublicKeyX25519, Maybe Text, Maybe Text, Maybe Word16)]
-> IO (Either StoreError RemoteHost)
forall a b e. (a -> b) -> e -> IO [a] -> IO (Either e b)
firstRow (RemoteCtrlId, Text, FilePath, APrivateSignKey,
 SignedObject Certificate, PrivateKeyEd25519, KeyHash,
 PublicKeyX25519, Maybe Text, Maybe Text, Maybe Word16)
-> RemoteHost
toRemoteHost (RemoteCtrlId -> StoreError
SERemoteHostNotFound RemoteCtrlId
remoteHostId) (IO
   [(RemoteCtrlId, Text, FilePath, APrivateSignKey,
     SignedObject Certificate, PrivateKeyEd25519, KeyHash,
     PublicKeyX25519, Maybe Text, Maybe Text, Maybe Word16)]
 -> ExceptT StoreError IO RemoteHost)
-> IO
     [(RemoteCtrlId, Text, FilePath, APrivateSignKey,
       SignedObject Certificate, PrivateKeyEd25519, KeyHash,
       PublicKeyX25519, Maybe Text, Maybe Text, Maybe Word16)]
-> ExceptT StoreError IO RemoteHost
forall a b. (a -> b) -> a -> b
$
    Connection
-> Query
-> Only RemoteCtrlId
-> IO
     [(RemoteCtrlId, Text, FilePath, APrivateSignKey,
       SignedObject Certificate, PrivateKeyEd25519, KeyHash,
       PublicKeyX25519, Maybe Text, Maybe Text, Maybe Word16)]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query Connection
db (Query
remoteHostQuery Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
" WHERE remote_host_id = ?") (RemoteCtrlId -> Only RemoteCtrlId
forall a. a -> Only a
Only RemoteCtrlId
remoteHostId)

getRemoteHostByFingerprint :: DB.Connection -> C.KeyHash -> IO (Maybe RemoteHost)
getRemoteHostByFingerprint :: Connection -> KeyHash -> IO (Maybe RemoteHost)
getRemoteHostByFingerprint Connection
db KeyHash
fingerprint =
  ((RemoteCtrlId, Text, FilePath, APrivateSignKey,
  SignedObject Certificate, PrivateKeyEd25519, KeyHash,
  PublicKeyX25519, Maybe Text, Maybe Text, Maybe Word16)
 -> RemoteHost)
-> IO
     [(RemoteCtrlId, Text, FilePath, APrivateSignKey,
       SignedObject Certificate, PrivateKeyEd25519, KeyHash,
       PublicKeyX25519, Maybe Text, Maybe Text, Maybe Word16)]
-> IO (Maybe RemoteHost)
forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> f [a] -> f (Maybe b)
maybeFirstRow (RemoteCtrlId, Text, FilePath, APrivateSignKey,
 SignedObject Certificate, PrivateKeyEd25519, KeyHash,
 PublicKeyX25519, Maybe Text, Maybe Text, Maybe Word16)
-> RemoteHost
toRemoteHost (IO
   [(RemoteCtrlId, Text, FilePath, APrivateSignKey,
     SignedObject Certificate, PrivateKeyEd25519, KeyHash,
     PublicKeyX25519, Maybe Text, Maybe Text, Maybe Word16)]
 -> IO (Maybe RemoteHost))
-> IO
     [(RemoteCtrlId, Text, FilePath, APrivateSignKey,
       SignedObject Certificate, PrivateKeyEd25519, KeyHash,
       PublicKeyX25519, Maybe Text, Maybe Text, Maybe Word16)]
-> IO (Maybe RemoteHost)
forall a b. (a -> b) -> a -> b
$
    Connection
-> Query
-> Only KeyHash
-> IO
     [(RemoteCtrlId, Text, FilePath, APrivateSignKey,
       SignedObject Certificate, PrivateKeyEd25519, KeyHash,
       PublicKeyX25519, Maybe Text, Maybe Text, Maybe Word16)]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query Connection
db (Query
remoteHostQuery Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
" WHERE host_fingerprint = ?") (KeyHash -> Only KeyHash
forall a. a -> Only a
Only KeyHash
fingerprint)

remoteHostQuery :: Query
remoteHostQuery :: Query
remoteHostQuery =
  [sql|
    SELECT remote_host_id, host_device_name, store_path, ca_key, ca_cert, id_key, host_fingerprint, host_dh_pub, bind_iface, bind_addr, bind_port
    FROM remote_hosts
  |]

toRemoteHost :: (Int64, Text, FilePath, C.APrivateSignKey, C.SignedObject X.Certificate, C.PrivateKeyEd25519, C.KeyHash, C.PublicKeyX25519, Maybe Text, Maybe Text, Maybe Word16) -> RemoteHost
toRemoteHost :: (RemoteCtrlId, Text, FilePath, APrivateSignKey,
 SignedObject Certificate, PrivateKeyEd25519, KeyHash,
 PublicKeyX25519, Maybe Text, Maybe Text, Maybe Word16)
-> RemoteHost
toRemoteHost (RemoteCtrlId
remoteHostId, Text
hostDeviceName, FilePath
storePath, APrivateSignKey
caKey, C.SignedObject SignedCertificate
caCert, PrivateKeyEd25519
idPrivKey, KeyHash
hostFingerprint, PublicKeyX25519
hostDhPubKey, Maybe Text
ifaceName_, Maybe Text
ifaceAddr_, Maybe Word16
bindPort_) =
  RemoteHost {RemoteCtrlId
remoteHostId :: RemoteCtrlId
remoteHostId :: RemoteCtrlId
remoteHostId, Text
hostDeviceName :: Text
hostDeviceName :: Text
hostDeviceName, FilePath
storePath :: FilePath
storePath :: FilePath
storePath, RCHostPairing
hostPairing :: RCHostPairing
hostPairing :: RCHostPairing
hostPairing, Maybe RCCtrlAddress
bindAddress_ :: Maybe RCCtrlAddress
bindAddress_ :: Maybe RCCtrlAddress
bindAddress_, Maybe Word16
bindPort_ :: Maybe Word16
bindPort_ :: Maybe Word16
bindPort_}
  where
    hostPairing :: RCHostPairing
hostPairing = RCHostPairing {APrivateSignKey
caKey :: APrivateSignKey
caKey :: APrivateSignKey
caKey, SignedCertificate
caCert :: SignedCertificate
caCert :: SignedCertificate
caCert, PrivateKeyEd25519
idPrivKey :: PrivateKeyEd25519
idPrivKey :: PrivateKeyEd25519
idPrivKey, knownHost :: Maybe KnownHostPairing
knownHost = KnownHostPairing -> Maybe KnownHostPairing
forall a. a -> Maybe a
Just KnownHostPairing
knownHost}
    knownHost :: KnownHostPairing
knownHost = KnownHostPairing {KeyHash
hostFingerprint :: KeyHash
hostFingerprint :: KeyHash
hostFingerprint, PublicKeyX25519
hostDhPubKey :: PublicKeyX25519
hostDhPubKey :: PublicKeyX25519
hostDhPubKey}
    bindAddress_ :: Maybe RCCtrlAddress
bindAddress_ = TransportHost -> Text -> RCCtrlAddress
RCCtrlAddress (TransportHost -> Text -> RCCtrlAddress)
-> Maybe TransportHost -> Maybe (Text -> RCCtrlAddress)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> TransportHost
decodeAddr (Text -> TransportHost) -> Maybe Text -> Maybe TransportHost
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
ifaceAddr_) Maybe (Text -> RCCtrlAddress) -> Maybe Text -> Maybe RCCtrlAddress
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Text
ifaceName_
    decodeAddr :: Text -> TransportHost
decodeAddr = (FilePath -> TransportHost)
-> (TransportHost -> TransportHost)
-> Either FilePath TransportHost
-> TransportHost
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (FilePath -> FilePath -> TransportHost
forall a. HasCallStack => FilePath -> a
error FilePath
"Error parsing TransportHost") TransportHost -> TransportHost
forall a. a -> a
id (Either FilePath TransportHost -> TransportHost)
-> (Text -> Either FilePath TransportHost) -> Text -> TransportHost
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either FilePath TransportHost
forall a. StrEncoding a => ByteString -> Either FilePath a
strDecode (ByteString -> Either FilePath TransportHost)
-> (Text -> ByteString) -> Text -> Either FilePath TransportHost
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8

updateHostPairing :: DB.Connection -> RemoteHostId -> Text -> C.PublicKeyX25519 -> Maybe RCCtrlAddress -> Maybe Word16 -> IO ()
updateHostPairing :: Connection
-> RemoteCtrlId
-> Text
-> PublicKeyX25519
-> Maybe RCCtrlAddress
-> Maybe Word16
-> IO ()
updateHostPairing Connection
db RemoteCtrlId
rhId Text
hostDeviceName PublicKeyX25519
hostDhPubKey Maybe RCCtrlAddress
rcAddr_ Maybe Word16
bindPort_ =
  Connection
-> Query
-> (Text, PublicKeyX25519, Maybe Text, Maybe Text, Maybe Word16,
    RemoteCtrlId)
-> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
    Connection
db
    [sql|
      UPDATE remote_hosts
      SET host_device_name = ?, host_dh_pub = ?, bind_addr = ?, bind_iface = ?, bind_port = ?
      WHERE remote_host_id = ?
    |]
    (Text
hostDeviceName, PublicKeyX25519
hostDhPubKey, Maybe Text
bindAddr_, Maybe Text
bindIface_, Maybe Word16
bindPort_, RemoteCtrlId
rhId)
  where
    (Maybe Text
bindAddr_, Maybe Text
bindIface_) = Maybe RCCtrlAddress -> (Maybe Text, Maybe Text)
rcCtrlAddressFields_ Maybe RCCtrlAddress
rcAddr_

rcCtrlAddressFields_ :: Maybe RCCtrlAddress -> (Maybe Text, Maybe Text)
rcCtrlAddressFields_ :: Maybe RCCtrlAddress -> (Maybe Text, Maybe Text)
rcCtrlAddressFields_ = (Maybe Text, Maybe Text)
-> (RCCtrlAddress -> (Maybe Text, Maybe Text))
-> Maybe RCCtrlAddress
-> (Maybe Text, Maybe Text)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Text
forall a. Maybe a
Nothing, Maybe Text
forall a. Maybe a
Nothing) ((RCCtrlAddress -> (Maybe Text, Maybe Text))
 -> Maybe RCCtrlAddress -> (Maybe Text, Maybe Text))
-> (RCCtrlAddress -> (Maybe Text, Maybe Text))
-> Maybe RCCtrlAddress
-> (Maybe Text, Maybe Text)
forall a b. (a -> b) -> a -> b
$ \RCCtrlAddress {TransportHost
address :: TransportHost
address :: RCCtrlAddress -> TransportHost
address, Text
interface :: Text
interface :: RCCtrlAddress -> Text
interface} -> (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text)
-> (ByteString -> Text) -> ByteString -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeASCII (ByteString -> Maybe Text) -> ByteString -> Maybe Text
forall a b. (a -> b) -> a -> b
$ TransportHost -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode TransportHost
address, Text -> Maybe Text
forall a. a -> Maybe a
Just Text
interface)

deleteRemoteHostRecord :: DB.Connection -> RemoteHostId -> IO ()
deleteRemoteHostRecord :: Connection -> RemoteCtrlId -> IO ()
deleteRemoteHostRecord Connection
db RemoteCtrlId
remoteHostId = Connection -> Query -> Only RemoteCtrlId -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute Connection
db Query
"DELETE FROM remote_hosts WHERE remote_host_id = ?" (RemoteCtrlId -> Only RemoteCtrlId
forall a. a -> Only a
Only RemoteCtrlId
remoteHostId)

insertRemoteCtrl :: DB.Connection -> Text -> RCCtrlPairing -> ExceptT StoreError IO RemoteCtrlId
insertRemoteCtrl :: Connection
-> Text -> RCCtrlPairing -> ExceptT StoreError IO RemoteCtrlId
insertRemoteCtrl Connection
db Text
ctrlDeviceName RCCtrlPairing {APrivateSignKey
caKey :: APrivateSignKey
caKey :: RCCtrlPairing -> APrivateSignKey
caKey, SignedCertificate
caCert :: SignedCertificate
caCert :: RCCtrlPairing -> SignedCertificate
caCert, KeyHash
ctrlFingerprint :: KeyHash
ctrlFingerprint :: RCCtrlPairing -> KeyHash
ctrlFingerprint, PublicKeyEd25519
idPubKey :: PublicKeyEd25519
idPubKey :: RCCtrlPairing -> PublicKeyEd25519
idPubKey, PrivateKeyX25519
dhPrivKey :: PrivateKeyX25519
dhPrivKey :: RCCtrlPairing -> PrivateKeyX25519
dhPrivKey, Maybe PrivateKeyX25519
prevDhPrivKey :: Maybe PrivateKeyX25519
prevDhPrivKey :: RCCtrlPairing -> Maybe PrivateKeyX25519
prevDhPrivKey} = do
  StoreError -> ExceptT StoreError IO () -> ExceptT StoreError IO ()
forall a.
StoreError -> ExceptT StoreError IO a -> ExceptT StoreError IO a
checkConstraint StoreError
SERemoteCtrlDuplicateCA (ExceptT StoreError IO () -> ExceptT StoreError IO ())
-> (IO () -> ExceptT StoreError IO ())
-> IO ()
-> ExceptT StoreError IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> ExceptT StoreError IO ()
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT StoreError IO ())
-> IO () -> ExceptT StoreError IO ()
forall a b. (a -> b) -> a -> b
$
    Connection
-> Query
-> (Text, APrivateSignKey, SignedObject Certificate, KeyHash,
    PublicKeyEd25519, PrivateKeyX25519, Maybe PrivateKeyX25519)
-> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
      Connection
db
      [sql|
      INSERT INTO remote_controllers
        (ctrl_device_name, ca_key, ca_cert, ctrl_fingerprint, id_pub, dh_priv_key, prev_dh_priv_key)
      VALUES
        (?, ?, ?, ?, ?, ?, ?)
    |]
      (Text
ctrlDeviceName, APrivateSignKey
caKey, SignedCertificate -> SignedObject Certificate
forall a. SignedExact a -> SignedObject a
C.SignedObject SignedCertificate
caCert, KeyHash
ctrlFingerprint, PublicKeyEd25519
idPubKey, PrivateKeyX25519
dhPrivKey, Maybe PrivateKeyX25519
prevDhPrivKey)
  IO RemoteCtrlId -> ExceptT StoreError IO RemoteCtrlId
forall a. IO a -> ExceptT StoreError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RemoteCtrlId -> ExceptT StoreError IO RemoteCtrlId)
-> IO RemoteCtrlId -> ExceptT StoreError IO RemoteCtrlId
forall a b. (a -> b) -> a -> b
$ Connection -> IO RemoteCtrlId
insertedRowId Connection
db

getRemoteCtrls :: DB.Connection -> IO [RemoteCtrl]
getRemoteCtrls :: Connection -> IO [RemoteCtrl]
getRemoteCtrls Connection
db =
  ((RemoteCtrlId, Text, APrivateSignKey, SignedObject Certificate,
  KeyHash, PublicKeyEd25519, PrivateKeyX25519,
  Maybe PrivateKeyX25519)
 -> RemoteCtrl)
-> [(RemoteCtrlId, Text, APrivateSignKey, SignedObject Certificate,
     KeyHash, PublicKeyEd25519, PrivateKeyX25519,
     Maybe PrivateKeyX25519)]
-> [RemoteCtrl]
forall a b. (a -> b) -> [a] -> [b]
map (RemoteCtrlId, Text, APrivateSignKey, SignedObject Certificate,
 KeyHash, PublicKeyEd25519, PrivateKeyX25519,
 Maybe PrivateKeyX25519)
-> RemoteCtrl
toRemoteCtrl ([(RemoteCtrlId, Text, APrivateSignKey, SignedObject Certificate,
   KeyHash, PublicKeyEd25519, PrivateKeyX25519,
   Maybe PrivateKeyX25519)]
 -> [RemoteCtrl])
-> IO
     [(RemoteCtrlId, Text, APrivateSignKey, SignedObject Certificate,
       KeyHash, PublicKeyEd25519, PrivateKeyX25519,
       Maybe PrivateKeyX25519)]
-> IO [RemoteCtrl]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection
-> Query
-> IO
     [(RemoteCtrlId, Text, APrivateSignKey, SignedObject Certificate,
       KeyHash, PublicKeyEd25519, PrivateKeyX25519,
       Maybe PrivateKeyX25519)]
forall r. FromRow r => Connection -> Query -> IO [r]
DB.query_ Connection
db Query
remoteCtrlQuery

getRemoteCtrl :: DB.Connection -> RemoteCtrlId -> ExceptT StoreError IO RemoteCtrl
getRemoteCtrl :: Connection -> RemoteCtrlId -> ExceptT StoreError IO RemoteCtrl
getRemoteCtrl Connection
db RemoteCtrlId
remoteCtrlId =
  IO (Either StoreError RemoteCtrl)
-> ExceptT StoreError IO RemoteCtrl
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either StoreError RemoteCtrl)
 -> ExceptT StoreError IO RemoteCtrl)
-> (IO
      [(RemoteCtrlId, Text, APrivateSignKey, SignedObject Certificate,
        KeyHash, PublicKeyEd25519, PrivateKeyX25519,
        Maybe PrivateKeyX25519)]
    -> IO (Either StoreError RemoteCtrl))
-> IO
     [(RemoteCtrlId, Text, APrivateSignKey, SignedObject Certificate,
       KeyHash, PublicKeyEd25519, PrivateKeyX25519,
       Maybe PrivateKeyX25519)]
-> ExceptT StoreError IO RemoteCtrl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((RemoteCtrlId, Text, APrivateSignKey, SignedObject Certificate,
  KeyHash, PublicKeyEd25519, PrivateKeyX25519,
  Maybe PrivateKeyX25519)
 -> RemoteCtrl)
-> StoreError
-> IO
     [(RemoteCtrlId, Text, APrivateSignKey, SignedObject Certificate,
       KeyHash, PublicKeyEd25519, PrivateKeyX25519,
       Maybe PrivateKeyX25519)]
-> IO (Either StoreError RemoteCtrl)
forall a b e. (a -> b) -> e -> IO [a] -> IO (Either e b)
firstRow (RemoteCtrlId, Text, APrivateSignKey, SignedObject Certificate,
 KeyHash, PublicKeyEd25519, PrivateKeyX25519,
 Maybe PrivateKeyX25519)
-> RemoteCtrl
toRemoteCtrl (RemoteCtrlId -> StoreError
SERemoteCtrlNotFound RemoteCtrlId
remoteCtrlId) (IO
   [(RemoteCtrlId, Text, APrivateSignKey, SignedObject Certificate,
     KeyHash, PublicKeyEd25519, PrivateKeyX25519,
     Maybe PrivateKeyX25519)]
 -> ExceptT StoreError IO RemoteCtrl)
-> IO
     [(RemoteCtrlId, Text, APrivateSignKey, SignedObject Certificate,
       KeyHash, PublicKeyEd25519, PrivateKeyX25519,
       Maybe PrivateKeyX25519)]
-> ExceptT StoreError IO RemoteCtrl
forall a b. (a -> b) -> a -> b
$
    Connection
-> Query
-> Only RemoteCtrlId
-> IO
     [(RemoteCtrlId, Text, APrivateSignKey, SignedObject Certificate,
       KeyHash, PublicKeyEd25519, PrivateKeyX25519,
       Maybe PrivateKeyX25519)]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query Connection
db (Query
remoteCtrlQuery Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
" WHERE remote_ctrl_id = ?") (RemoteCtrlId -> Only RemoteCtrlId
forall a. a -> Only a
Only RemoteCtrlId
remoteCtrlId)

getRemoteCtrlByFingerprint :: DB.Connection -> C.KeyHash -> IO (Maybe RemoteCtrl)
getRemoteCtrlByFingerprint :: Connection -> KeyHash -> IO (Maybe RemoteCtrl)
getRemoteCtrlByFingerprint Connection
db KeyHash
fingerprint =
  ((RemoteCtrlId, Text, APrivateSignKey, SignedObject Certificate,
  KeyHash, PublicKeyEd25519, PrivateKeyX25519,
  Maybe PrivateKeyX25519)
 -> RemoteCtrl)
-> IO
     [(RemoteCtrlId, Text, APrivateSignKey, SignedObject Certificate,
       KeyHash, PublicKeyEd25519, PrivateKeyX25519,
       Maybe PrivateKeyX25519)]
-> IO (Maybe RemoteCtrl)
forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> f [a] -> f (Maybe b)
maybeFirstRow (RemoteCtrlId, Text, APrivateSignKey, SignedObject Certificate,
 KeyHash, PublicKeyEd25519, PrivateKeyX25519,
 Maybe PrivateKeyX25519)
-> RemoteCtrl
toRemoteCtrl (IO
   [(RemoteCtrlId, Text, APrivateSignKey, SignedObject Certificate,
     KeyHash, PublicKeyEd25519, PrivateKeyX25519,
     Maybe PrivateKeyX25519)]
 -> IO (Maybe RemoteCtrl))
-> IO
     [(RemoteCtrlId, Text, APrivateSignKey, SignedObject Certificate,
       KeyHash, PublicKeyEd25519, PrivateKeyX25519,
       Maybe PrivateKeyX25519)]
-> IO (Maybe RemoteCtrl)
forall a b. (a -> b) -> a -> b
$
    Connection
-> Query
-> Only KeyHash
-> IO
     [(RemoteCtrlId, Text, APrivateSignKey, SignedObject Certificate,
       KeyHash, PublicKeyEd25519, PrivateKeyX25519,
       Maybe PrivateKeyX25519)]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
DB.query Connection
db (Query
remoteCtrlQuery Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
" WHERE ctrl_fingerprint = ?") (KeyHash -> Only KeyHash
forall a. a -> Only a
Only KeyHash
fingerprint)

remoteCtrlQuery :: Query
remoteCtrlQuery :: Query
remoteCtrlQuery =
  [sql|
    SELECT remote_ctrl_id, ctrl_device_name, ca_key, ca_cert, ctrl_fingerprint, id_pub, dh_priv_key, prev_dh_priv_key
    FROM remote_controllers
  |]

toRemoteCtrl ::
  ( RemoteCtrlId,
    Text,
    C.APrivateSignKey,
    C.SignedObject X.Certificate,
    C.KeyHash,
    C.PublicKeyEd25519,
    C.PrivateKeyX25519,
    Maybe C.PrivateKeyX25519
  ) ->
  RemoteCtrl
toRemoteCtrl :: (RemoteCtrlId, Text, APrivateSignKey, SignedObject Certificate,
 KeyHash, PublicKeyEd25519, PrivateKeyX25519,
 Maybe PrivateKeyX25519)
-> RemoteCtrl
toRemoteCtrl (RemoteCtrlId
remoteCtrlId, Text
ctrlDeviceName, APrivateSignKey
caKey, C.SignedObject SignedCertificate
caCert, KeyHash
ctrlFingerprint, PublicKeyEd25519
idPubKey, PrivateKeyX25519
dhPrivKey, Maybe PrivateKeyX25519
prevDhPrivKey) =
  let ctrlPairing :: RCCtrlPairing
ctrlPairing = RCCtrlPairing {APrivateSignKey
caKey :: APrivateSignKey
caKey :: APrivateSignKey
caKey, SignedCertificate
caCert :: SignedCertificate
caCert :: SignedCertificate
caCert, KeyHash
ctrlFingerprint :: KeyHash
ctrlFingerprint :: KeyHash
ctrlFingerprint, PublicKeyEd25519
idPubKey :: PublicKeyEd25519
idPubKey :: PublicKeyEd25519
idPubKey, PrivateKeyX25519
dhPrivKey :: PrivateKeyX25519
dhPrivKey :: PrivateKeyX25519
dhPrivKey, Maybe PrivateKeyX25519
prevDhPrivKey :: Maybe PrivateKeyX25519
prevDhPrivKey :: Maybe PrivateKeyX25519
prevDhPrivKey}
   in RemoteCtrl {RemoteCtrlId
remoteCtrlId :: RemoteCtrlId
remoteCtrlId :: RemoteCtrlId
remoteCtrlId, Text
ctrlDeviceName :: Text
ctrlDeviceName :: Text
ctrlDeviceName, RCCtrlPairing
ctrlPairing :: RCCtrlPairing
ctrlPairing :: RCCtrlPairing
ctrlPairing}

updateRemoteCtrl :: DB.Connection -> RemoteCtrl -> Text -> C.PrivateKeyX25519 -> IO ()
updateRemoteCtrl :: Connection -> RemoteCtrl -> Text -> PrivateKeyX25519 -> IO ()
updateRemoteCtrl Connection
db RemoteCtrl {RemoteCtrlId
remoteCtrlId :: RemoteCtrl -> RemoteCtrlId
remoteCtrlId :: RemoteCtrlId
remoteCtrlId} Text
ctrlDeviceName PrivateKeyX25519
dhPrivKey =
  Connection
-> Query -> (Text, PrivateKeyX25519, RemoteCtrlId) -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute
    Connection
db
    [sql|
      UPDATE remote_controllers
      SET ctrl_device_name = ?, dh_priv_key = ?, prev_dh_priv_key = dh_priv_key
      WHERE remote_ctrl_id = ?
    |]
    (Text
ctrlDeviceName, PrivateKeyX25519
dhPrivKey, RemoteCtrlId
remoteCtrlId)

deleteRemoteCtrlRecord :: DB.Connection -> RemoteCtrlId -> IO ()
deleteRemoteCtrlRecord :: Connection -> RemoteCtrlId -> IO ()
deleteRemoteCtrlRecord Connection
db RemoteCtrlId
remoteCtrlId =
  Connection -> Query -> Only RemoteCtrlId -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
DB.execute Connection
db Query
"DELETE FROM remote_controllers WHERE remote_ctrl_id = ?" (RemoteCtrlId -> Only RemoteCtrlId
forall a. a -> Only a
Only RemoteCtrlId
remoteCtrlId)