summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--erebos.cabal1
-rw-r--r--main/Test.hs23
-rw-r--r--src/Erebos/Chatroom.hs120
-rw-r--r--test/chatroom.test14
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")