Chatroom shared type

4 files changed, 158 insertions, 0 deletions

diff --git a/erebos.cabal b/erebos.cabal
index c616e11..b824e03 100644
--- a/erebos.cabal
+++ b/erebos.cabal
@@ -82,6 +82,7 @@ library
     exposed-modules:
         Erebos.Attach
         Erebos.Channel
+        Erebos.Chatroom
         Erebos.Contact
         Erebos.Identity
         Erebos.Message
diff --git a/main/Test.hs b/main/Test.hs
index 991cf85..182d941 100644
--- a/main/Test.hs
+++ b/main/Test.hs
@@ -29,6 +29,7 @@ import System.IO
 import System.IO.Error
 
 import Erebos.Attach
+import Erebos.Chatroom
 import Erebos.Contact
 import Erebos.Identity
 import Erebos.Message
@@ -264,6 +265,8 @@ commands = map (T.pack *** id)
     , ("dm-send-contact", cmdDmSendContact)
     , ("dm-list-peer", cmdDmListPeer)
     , ("dm-list-contact", cmdDmListContact)
+    , ("chatroom-create", cmdChatroomCreate)
+    , ("chatroom-list-local", cmdChatroomListLocal)
     ]
 
 cmdStore :: Command
@@ -565,3 +568,23 @@ cmdDmListContact = do
     [cid] <- asks tiParams
     Just to <- contactIdentity <$> getContact cid
     dmList to
+
+cmdChatroomCreate :: Command
+cmdChatroomCreate = do
+    [name] <- asks tiParams
+    void $ createChatroom (Just name) Nothing
+
+cmdChatroomListLocal :: Command
+cmdChatroomListLocal = do
+    [] <- asks tiParams
+    h <- getHead
+    let rooms = fromSetBy (comparing $ roomName <=< roomStateRoom) . lookupSharedValue . lsShared . headObject $ h
+    forM_ rooms $ \room -> do
+        r:_ <- return $ filterAncestors $ concatMap storedRoots $ toComponents room
+        cmdOut $ concat
+            [ "chatroom-list-item "
+            , show $ refDigest $ storedRef r
+            , " "
+            , maybe "<unnamed>" T.unpack $ roomName =<< roomStateRoom room
+            ]
+    cmdOut "chatroom-list-done"
diff --git a/src/Erebos/Chatroom.hs b/src/Erebos/Chatroom.hs
new file mode 100644
index 0000000..90848dd
--- /dev/null
+++ b/src/Erebos/Chatroom.hs
@@ -0,0 +1,120 @@
+module Erebos.Chatroom (
+    Chatroom(..),
+    ChatroomData(..),
+    validateChatroom,
+
+    ChatroomState(..),
+    createChatroom,
+) where
+
+import Control.Monad
+import Control.Monad.Except
+
+import Data.Monoid
+import Data.Text (Text)
+
+import Erebos.PubKey
+import Erebos.Set
+import Erebos.State
+import Erebos.Storage
+import Erebos.Storage.Merge
+
+
+data ChatroomData = ChatroomData
+    { rdPrev :: [Stored (Signed ChatroomData)]
+    , rdName :: Maybe Text
+    , rdDescription :: Maybe Text
+    , rdKey :: Stored PublicKey
+    }
+
+data Chatroom = Chatroom
+    { roomData :: [Stored (Signed ChatroomData)]
+    , roomName :: Maybe Text
+    , roomDescription :: Maybe Text
+    , roomKey :: Stored PublicKey
+    }
+
+instance Storable ChatroomData where
+    store' ChatroomData {..} = storeRec $ do
+        mapM_ (storeRef "SPREV") rdPrev
+        storeMbText "name" rdName
+        storeMbText "description" rdDescription
+        storeRef "key" rdKey
+
+    load' = loadRec $ do
+        rdPrev <- loadRefs "SPREV"
+        rdName <- loadMbText "name"
+        rdDescription <- loadMbText "description"
+        rdKey <- loadRef "key"
+        return ChatroomData {..}
+
+validateChatroom :: [Stored (Signed ChatroomData)] -> Except String Chatroom
+validateChatroom roomData = do
+    when (null roomData) $ throwError "null data"
+    when (not $ getAll $ walkAncestors verifySignatures roomData) $ do
+        throwError "signature verification failed"
+
+    let roomName = findPropertyFirst (rdName . fromStored . signedData) roomData
+        roomDescription = findPropertyFirst (rdDescription . fromStored . signedData) roomData
+    roomKey <- maybe (throwError "missing key") return $
+        findPropertyFirst (Just . rdKey . fromStored . signedData) roomData
+    return Chatroom {..}
+  where
+    verifySignatures sdata =
+        let rdata = fromSigned sdata
+            required = concat
+                [ [ rdKey rdata ]
+                , map (rdKey . fromSigned) $ rdPrev rdata
+                ]
+         in All $ all (fromStored sdata `isSignedBy`) required
+
+
+data ChatroomStateData = ChatroomStateData
+    { rsdPrev :: [Stored ChatroomStateData]
+    , rsdRoom :: [Stored (Signed ChatroomData)]
+    }
+
+data ChatroomState = ChatroomState
+    { roomStateData :: [Stored ChatroomStateData]
+    , roomStateRoom :: Maybe Chatroom
+    }
+
+instance Storable ChatroomStateData where
+    store' ChatroomStateData {..} = storeRec $ do
+        forM_ rsdPrev $ storeRef "PREV"
+        forM_ rsdRoom $ storeRef "room"
+
+    load' = loadRec $ do
+        rsdPrev <- loadRefs "PREV"
+        rsdRoom <- loadRefs "room"
+        return ChatroomStateData {..}
+
+instance Mergeable ChatroomState where
+    type Component ChatroomState = ChatroomStateData
+
+    mergeSorted cdata = ChatroomState
+        { roomStateData = cdata
+        , roomStateRoom = either (const Nothing) Just $ runExcept $
+            validateChatroom $ concat $ findProperty ((\case [] -> Nothing; xs -> Just xs) . rsdRoom) cdata
+        }
+
+    toComponents = roomStateData
+
+instance SharedType (Set ChatroomState) where
+    sharedTypeID _ = mkSharedTypeID "7bc71cbf-bc43-42b1-b413-d3a2c9a2aae0"
+
+createChatroom :: (MonadStorage m, MonadHead LocalState m, MonadIO m, MonadError String m) => Maybe Text -> Maybe Text -> m Chatroom
+createChatroom rdName rdDescription = do
+    st <- getStorage
+    (secret, rdKey) <- liftIO $ generateKeys st
+    let rdPrev = []
+    rdata <- wrappedStore st =<< sign secret =<< wrappedStore st ChatroomData {..}
+    room <- liftEither $ runExcept $ validateChatroom [ rdata ]
+
+    updateLocalHead_ $ updateSharedState_ $ \rooms -> do
+        sdata <- wrappedStore st ChatroomStateData
+            { rsdPrev = []
+            , rsdRoom = [ rdata ]
+            }
+        storeSetAdd st (mergeSorted @ChatroomState [ sdata ]) rooms
+    return room
diff --git a/test/chatroom.test b/test/chatroom.test
new file mode 100644
index 0000000..b63b01b
--- /dev/null
+++ b/test/chatroom.test
@@ -0,0 +1,14 @@
+test LocalChatrooms:
+	spawn as p1
+	with p1:
+		send "create-identity Device1 Owner1"
+
+		send "chatroom-create first"
+		send "chatroom-create second"
+
+		send "chatroom-list-local"
+		expect /chatroom-list-item [a-z0-9#]+ first/
+		expect /chatroom-list-item [a-z0-9#]+ second/
+		local:
+			expect /chatroom-list-(.*)/ capture done
+			guard (done == "done")