SUSPEND and DELETE connection

src/ConnStore.hs

@@ -12,17 +12,19 @@ data Connection = Connection
     recipientKey :: PublicKey,
     senderId :: ConnId,
     senderKey :: Maybe PublicKey,
-    active :: Bool
+    status :: ConnStatus
   }
 
+data ConnStatus = ConnActive | ConnSuspended
+
 class MonadConnStore s m where
   createConn :: s -> RecipientKey -> m (Either ErrorType Connection)
   getConn :: s -> Sing (a :: Party) -> ConnId -> m (Either ErrorType Connection)
   secureConn :: s -> RecipientId -> SenderKey -> m (Either ErrorType ())
+  suspendConn :: s -> RecipientId -> m (Either ErrorType ())
+  deleteConn :: s -> RecipientId -> m (Either ErrorType ())
 
--- suspendConn :: RecipientId -> m (Either ErrorType ())
--- deleteConn :: RecipientId -> m (Either ErrorType ())
-
+-- TODO stub
 newConnection :: RecipientKey -> Connection
 newConnection rKey =
   Connection
@@ -30,5 +32,5 @@ newConnection rKey =
       recipientKey = rKey,
       senderId = "2",
       senderKey = Nothing,
-      active = True
+      status = ConnActive
     }

src/ConnStore/STM.hs

@@ -1,6 +1,8 @@
-{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -12,6 +14,7 @@ import ConnStore
 import Control.Monad.IO.Unlift
 import Data.Map (Map)
 import qualified Data.Map as M
+import Data.Singletons
 import Transmission
 import UnliftIO.STM
 
@@ -26,38 +29,62 @@ newConnStore :: STM STMConnStore
 newConnStore = newTVar ConnStoreData {connections = M.empty, senders = M.empty}
 
 instance MonadUnliftIO m => MonadConnStore STMConnStore m where
-  createConn store rKey = atomically do
+  createConn :: STMConnStore -> RecipientKey -> m (Either ErrorType Connection)
+  createConn store rKey = atomically $ do
     db <- readTVar store
     let c@Connection {recipientId = rId, senderId = sId} = newConnection rKey
         db' =
-          ConnStoreData
+          db
             { connections = M.insert rId c (connections db),
               senders = M.insert sId rId (senders db)
             }
     writeTVar store db'
     return $ Right c
 
-  -- TODO do not return suspended connections
-  getConn store SRecipient rId = atomically do
+  getConn :: STMConnStore -> Sing (p :: Party) -> ConnId -> m (Either ErrorType Connection)
+  getConn store SRecipient rId = atomically $ do
     db <- readTVar store
     return $ getRcpConn db rId
-  getConn store SSender sId = atomically do
+  getConn store SSender sId = atomically $ do
     db <- readTVar store
-    return $ maybe (Left AUTH) (getRcpConn db) $ M.lookup sId $ senders db
-  getConn _ SBroker _ = atomically do
+    let rId = M.lookup sId $ senders db
+    return $ maybe (Left AUTH) (getRcpConn db) rId
+  getConn _ SBroker _ =
     return $ Left INTERNAL
 
-  secureConn store rId sKey = atomically do
-    db <- readTVar store
-    let conn = getRcpConn db rId
-    either (return . Left) (updateConn db) conn
-    where
-      updateConn db c = case senderKey c of
-        Just _ -> return $ Left AUTH
-        Nothing -> do
-          let db' = db {connections = M.insert rId c {senderKey = Just sKey} (connections db)}
-          writeTVar store db'
-          return $ Right ()
+  secureConn store rId sKey = updateConnections store rId $ \db c ->
+    case senderKey c of
+      Just _ -> (Left AUTH, db)
+      _ -> (Right (), db {connections = M.insert rId c {senderKey = Just sKey} (connections db)})
+
+  suspendConn :: STMConnStore -> RecipientId -> m (Either ErrorType ())
+  suspendConn store rId = updateConnections store rId $ \db c ->
+    (Right (), db {connections = M.insert rId c {status = ConnSuspended} (connections db)})
+
+  deleteConn :: STMConnStore -> RecipientId -> m (Either ErrorType ())
+  deleteConn store rId = updateConnections store rId $ \db c ->
+    ( Right (),
+      db
+        { connections = M.delete rId (connections db),
+          senders = M.delete (senderId c) (senders db)
+        }
+    )
+
+updateConnections ::
+  MonadUnliftIO m =>
+  STMConnStore ->
+  RecipientId ->
+  (ConnStoreData -> Connection -> (Either ErrorType (), ConnStoreData)) ->
+  m (Either ErrorType ())
+updateConnections store rId update = atomically $ do
+  db <- readTVar store
+  let conn = getRcpConn db rId
+  either (return . Left) (_update db) conn
+  where
+    _update db c = do
+      let (res, db') = update db c
+      writeTVar store db'
+      return res
 
 getRcpConn :: ConnStoreData -> RecipientId -> Either ErrorType Connection
 getRcpConn db rId = maybe (Left AUTH) Right . M.lookup rId $ connections db

src/Server.hs

@@ -83,15 +83,19 @@ client h Client {queue} = loop
     processCommand connId cmd = do
       st <- asks connStore
       case cmd of
-        Cmd SRecipient (CREATE recipientKey) ->
+        Cmd SRecipient (CREATE rKey) ->
           either (mkSigned "" . ERROR) connResponce
-            <$> createConn st recipientKey
+            <$> createConn st rKey
         Cmd SRecipient SUB -> do
           -- TODO message subscription
           return ok
-        Cmd SRecipient (SECURE senderKey) -> do
-          mkSigned connId . either ERROR (const OK)
-            <$> secureConn st connId senderKey
+        Cmd SRecipient (SECURE sKey) -> okResponse <$> secureConn st connId sKey
+        Cmd SRecipient SUSPEND -> okResponse <$> suspendConn st connId
+        Cmd SRecipient DELETE -> okResponse <$> deleteConn st connId
+        Cmd SSender (SEND msgBody) -> do
+          -- TODO message delivery
+          mkSigned connId . either ERROR (deliverTo msgBody)
+            <$> getConn st SSender connId
         Cmd SBroker _ -> return (connId, cmd)
         Cmd _ _ -> return ok
       where
@@ -103,3 +107,12 @@ client h Client {queue} = loop
 
         connResponce :: Connection -> Signed
         connResponce Connection {recipientId = rId, senderId = sId} = mkSigned rId $ CONN rId sId
+
+        okResponse :: Either ErrorType () -> Signed
+        okResponse = mkSigned connId . either ERROR (const OK)
+
+        -- TODO stub
+        deliverTo :: MsgBody -> Connection -> Command 'Broker
+        deliverTo _msgBody conn = case status conn of
+          ConnActive -> OK
+          ConnSuspended -> ERROR AUTH

tests/Test.hs

@@ -17,7 +17,8 @@ main :: IO ()
 main = hspec do
   describe "SMP syntax" syntaxTests
   describe "SMP connections" do
-    createSecureSendTest
+    testCreateSecure
+    testCreateDelete
 
 pattern Resp :: ConnId -> Command 'Broker -> TransmissionOrError
 pattern Resp connId command = ("", (connId, Right (Cmd SBroker command)))
@@ -31,8 +32,8 @@ sendRecv h t = tPutRaw h t >> tGet fromServer h
 (#==) :: (HasCallStack, Eq a, Show a) => (a, a) -> String -> Assertion
 (actual, expected) #== message = assertEqual message expected actual
 
-createSecureSendTest :: SpecWith ()
-createSecureSendTest = do
+testCreateSecure :: SpecWith ()
+testCreateSecure = do
   it "CREATE and SECURE connection, SEND messages (no delivery yet)" $
     smpTest \h -> do
       Resp rId (CONN rId1 sId) <- sendRecv h ("", "", "CREATE 123")
@@ -63,7 +64,64 @@ createSecureSendTest = do
       (ok3, OK) #== "accepts signed SEND"
 
       Resp _ err5 <- sendRecv h ("", sId, "SEND :hello")
-      (err5, ERROR AUTH) #== "accepts unsigned SEND"
+      (err5, ERROR AUTH) #== "rejects unsigned SEND"
+
+testCreateDelete :: SpecWith ()
+testCreateDelete = do
+  it "CREATE, SUSPEND and DELETE connection, SEND messages (no delivery yet)" $
+    smpTest \h -> do
+      Resp rId (CONN rId1 sId) <- sendRecv h ("", "", "CREATE 123")
+      (rId1, rId) #== "creates connection"
+
+      Resp _ ok1 <- sendRecv h ("123", rId, "SECURE 456")
+      (ok1, OK) #== "secures connection"
+
+      Resp _ ok2 <- sendRecv h ("456", sId, "SEND :hello")
+      (ok2, OK) #== "accepts signed SEND"
+
+      Resp _ err1 <- sendRecv h ("1234", rId, "SUSPEND")
+      (err1, ERROR AUTH) #== "rejects SUSPEND with wrong signature (password atm)"
+
+      Resp _ err2 <- sendRecv h ("123", sId, "SUSPEND")
+      (err2, ERROR AUTH) #== "rejects SUSPEND with sender's ID"
+
+      Resp rId2 ok3 <- sendRecv h ("123", rId, "SUSPEND")
+      (ok3, OK) #== "suspends connection"
+      (rId2, rId) #== "same connection ID in response 2"
+
+      Resp _ err3 <- sendRecv h ("456", sId, "SEND :hello")
+      (err3, ERROR AUTH) #== "rejects signed SEND"
+
+      Resp _ err4 <- sendRecv h ("", sId, "SEND :hello")
+      (err4, ERROR AUTH) #== "reject unsigned SEND too"
+
+      Resp _ ok4 <- sendRecv h ("123", rId, "SUSPEND")
+      (ok4, OK) #== "accepts SUSPEND when suspended"
+
+      Resp _ ok5 <- sendRecv h ("123", rId, "SUB")
+      (ok5, OK) #== "accepts SUB when suspended"
+
+      Resp _ err5 <- sendRecv h ("1234", rId, "DELETE")
+      (err5, ERROR AUTH) #== "rejects DELETE with wrong signature (password atm)"
+
+      Resp _ err6 <- sendRecv h ("123", sId, "DELETE")
+      (err6, ERROR AUTH) #== "rejects DELETE with sender's ID"
+
+      Resp rId3 ok6 <- sendRecv h ("123", rId, "DELETE")
+      (ok6, OK) #== "deletes connection"
+      (rId3, rId) #== "same connection ID in response 3"
+
+      Resp _ err7 <- sendRecv h ("456", sId, "SEND :hello")
+      (err7, ERROR AUTH) #== "rejects signed SEND when deleted"
+
+      Resp _ err8 <- sendRecv h ("", sId, "SEND :hello")
+      (err8, ERROR AUTH) #== "rejects unsigned SEND too when deleted"
+
+      Resp _ err9 <- sendRecv h ("123", rId, "SUSPEND")
+      (err9, ERROR AUTH) #== "rejects SUSPEND when deleted"
+
+      Resp _ err10 <- sendRecv h ("123", rId, "SUB")
+      (err10, ERROR AUTH) #== "rejects SUB when deleted"
 
 syntaxTests :: SpecWith ()
 syntaxTests = do