diff options
| -rw-r--r-- | erebos.cabal | 1 | ||||
| -rw-r--r-- | main/Test.hs | 23 | ||||
| -rw-r--r-- | src/Erebos/Chatroom.hs | 120 | ||||
| -rw-r--r-- | test/chatroom.test | 14 |
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") |